CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Literate programming AST now tree-shaped

Browse Source
This commit is contained in:
Denis Merigoux 2020-10-04 01:25:37 +02:00
parent 5aa596c0a8
commit cdfa9038cf
29 changed files with 1539 additions and 2299 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Makefile
View File

@ -18,7 +18,6 @@ install-dependencies-ocaml:
menhirLib \
dune dune-build-info \
cmdliner obelisk \
tls cohttp lwt cohttp-lwt-unix yojson\
re reason\
obelisk\
ocamlgraph
@ -159,7 +158,9 @@ all: install-dependencies build doc tests all_examples website-assets
clean:
dune clean
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) clean
$(MAKE) -C $(ENGLISH_DUMMY_DIR) clean
$(MAKE) -C $(US_TAX_CODE_DIR) clean
$(MAKE) -C $(TUTORIAL_DIR) clean
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) clean
inspect:
gitinspector -f ml,mli,mly,iro,tex,catala,md,ir --grading

21
dune-project
View File

@ -31,26 +31,5 @@
)
)
(package
(name legifrance_catala)
(synopsis "Interaction tool between French Catala programs and the LegiFrance API")
(depends
(ocaml (>= 4.07.0))
(ANSITerminal (>= 0.8.2))
(sedlex (>= 2.1))
(menhir (>= 20200211))
(menhirLib (>= 20200211))
(dune-build-info (>= 2.0.1))
(cmdliner (>= 1.0.4))
(re (>= 1.9.0))
(dune (and :build ))
(reason ( >= 3.6.0))
(yojson ( >= 1.7.0))
(cohttp-lwt-unix ( >= 2.5.1))
(lwt ( >= 5.3.0))
(cohttp ( >= 2.5.1))
(tls ( >= 0.11.1))
)
)
(using menhir 2.1)

5
examples/us_tax_code/section_132.catala_en
View File

@ -1,11 +1,8 @@
@@Section 132@@
/*
# We only formalize part (c) here
*/
@@Begin metadata@@
/*
# We only formalize part (c) here
declaration enumeration DiscountType:
-- Property
-- Services

42
legifrance_catala.opam
View File

@ -1,42 +0,0 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "0.1.1"
synopsis:
"Interaction tool between French Catala programs and the LegiFrance API"
maintainer: ["denis.merigoux@inria.fr"]
authors: ["Denis Merigoux"]
license: "Apache2"
homepage: "https://github.com/CatalaLang/catala"
bug-reports: "https://github.com/CatalaLang/catala/issues"
depends: [
"ocaml" {>= "4.07.0"}
"ANSITerminal" {>= "0.8.2"}
"sedlex" {>= "2.1"}
"menhir" {>= "20200211"}
"menhirLib" {>= "20200211"}
"dune-build-info" {>= "2.0.1"}
"cmdliner" {>= "1.0.4"}
"re" {>= "1.9.0"}
"dune" {build}
"reason" {>= "3.6.0"}
"yojson" {>= "1.7.0"}
"cohttp-lwt-unix" {>= "2.5.1"}
"lwt" {>= "5.3.0"}
"cohttp" {>= "2.5.1"}
"tls" {>= "0.11.1"}
]
build: [
["dune" "subst"] {pinned}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/CatalaLang/catala.git"

15
src/catala/catala_surface/catala_ast.ml
View File

@ -189,14 +189,21 @@ type law_include =
| CatalaFile of string Pos.marked
| LegislativeText of string Pos.marked
type program_item =
| LawHeading of string * int
| LawArticle of law_article
type law_article_item =
| LawText of string
| CodeBlock of code_block * source_repr
| MetadataBlock of code_block * source_repr
| LawInclude of law_include
type law_heading = { law_heading_name : string; law_heading_precedence : int }
type law_structure =
| LawHeading of law_heading * law_structure list
| LawArticle of law_article * law_article_item list
| MetadataBlock of code_block * source_repr
| IntermediateText of string
type program_item = LawStructure of law_structure
type program = { program_items : program_item list; program_source_files : string list }
type source_file_or_master =

23
src/catala/catala_surface/desugaring.ml
View File

@ -206,13 +206,30 @@ let process_scope_use (ctxt : Name_resolution.context) (prgm : Scope_ast.program
let translate_program_to_scope (ctxt : Name_resolution.context) (prgm : Catala_ast.program) :
Scope_ast.program =
let empty_prgm = Uid.ScopeMap.empty in
let processer (prgm : Scope_ast.program) (item : Catala_ast.program_item) : Scope_ast.program =
let processer_article_item (prgm : Scope_ast.program) (item : Catala_ast.law_article_item) :
Scope_ast.program =
match item with
| CodeBlock (block, _) | MetadataBlock (block, _) ->
| CodeBlock (block, _) ->
List.fold_left
(fun prgm item ->
match Pos.unmark item with ScopeUse use -> process_scope_use ctxt prgm use | _ -> prgm)
prgm block
| _ -> prgm
in
List.fold_left processer empty_prgm prgm.program_items
let rec processer_structure (prgm : Scope_ast.program) (item : Catala_ast.law_structure) :
Scope_ast.program =
match item with
| LawHeading (_, children) ->
List.fold_left (fun prgm child -> processer_structure prgm child) prgm children
| LawArticle (_, children) ->
List.fold_left (fun prgm child -> processer_article_item prgm child) prgm children
| MetadataBlock (b, c) -> processer_article_item prgm (CodeBlock (b, c))
| IntermediateText _ -> prgm
in
let processer_item (prgm : Scope_ast.program) (item : Catala_ast.program_item) : Scope_ast.program
=
match item with LawStructure s -> processer_structure prgm s
in
List.fold_left processer_item empty_prgm prgm.program_items

23
src/catala/catala_surface/name_resolution.ml
View File

@ -237,12 +237,29 @@ let process_code_block (ctxt : context) (block : Catala_ast.code_block)
(process_item : context -> Catala_ast.code_item Pos.marked -> context) : context =
List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block
(** Process a program item *)
let process_law_article_item (ctxt : context) (item : Catala_ast.law_article_item)
(process_item : context -> Catala_ast.code_item Pos.marked -> context) : context =
match item with CodeBlock (block, _) -> process_code_block ctxt block process_item | _ -> ctxt
(** Process a law structure *)
let rec process_law_structure (ctxt : context) (s : Catala_ast.law_structure)
(process_item : context -> Catala_ast.code_item Pos.marked -> context) : context =
match s with
| Catala_ast.LawHeading (_, children) ->
List.fold_left (fun ctxt child -> process_law_structure ctxt child process_item) ctxt children
| Catala_ast.LawArticle (_, children) ->
List.fold_left
(fun ctxt child -> process_law_article_item ctxt child process_item)
ctxt children
| Catala_ast.MetadataBlock (b, c) ->
process_law_article_item ctxt (Catala_ast.CodeBlock (b, c)) process_item
| Catala_ast.IntermediateText _ -> ctxt
(** Process a program item *)
let process_program_item (ctxt : context) (item : Catala_ast.program_item)
(process_item : context -> Catala_ast.code_item Pos.marked -> context) : context =
match item with
| CodeBlock (block, _) | MetadataBlock (block, _) -> process_code_block ctxt block process_item
| _ -> ctxt
match item with Catala_ast.LawStructure s -> process_law_structure ctxt s process_item
(** Derive the context from metadata, in two passes *)
let form_context (prgm : Catala_ast.program) : context =

2035
src/catala/catala_surface/parser.messages
View File

File diff suppressed because it is too large Load Diff

97
src/catala/catala_surface/parser.mly
View File

@ -497,20 +497,8 @@ metadata_block:
(code, (text, pos))
}
source_file_item:
| title = LAW_ARTICLE {
let (title, id, exp_date) = title in LawArticle {
law_article_name = (title, $sloc);
law_article_id = id;
law_article_expiration_date = exp_date;
}
}
| heading = LAW_HEADING { let (title, precedence) = heading in LawHeading (title, precedence) }
law_article_item:
| text = LAW_TEXT { LawText text }
| BEGIN_METADATA code = metadata_block {
let (code, source_repr) = code in
MetadataBlock (code, source_repr)
}
| BEGIN_CODE code_and_pos = code text = END_CODE {
let (code, pos) = code_and_pos in
CodeBlock (code, (text, pos))
@ -519,8 +507,43 @@ source_file_item:
LawInclude includ
}
law_article:
| title = LAW_ARTICLE {
let (title, id, exp_date) = title in {
law_article_name = (title, $sloc);
law_article_id = id;
law_article_expiration_date = exp_date;
}
}
law_heading:
| heading = LAW_HEADING { let (title, precedence) = heading in {
law_heading_name = title;
law_heading_precedence = precedence;
}
}
law_articles_items:
| hd = law_article_item tl = law_articles_items{ hd::tl }
| { [] }
source_file_item:
| article = law_article items = law_articles_items {
LawStructure (LawArticle (article, items))
}
| heading = law_heading {
LawStructure (LawHeading (heading, []))
}
| BEGIN_METADATA code = metadata_block {
let (code, source_repr) = code in
LawStructure (MetadataBlock (code, source_repr))
}
| text = LAW_TEXT { LawStructure (IntermediateText text) }
source_file:
| i = source_file_item f = source_file { i::f }
| i = source_file_item f = source_file {
i::f
}
| EOF { [] }
master_file_include:
@ -536,4 +559,48 @@ master_file_includes:
source_file_or_master:
| MASTER_FILE is = master_file_includes { MasterFile is }
| f = source_file { SourceFile f }
| f = source_file {
(*
now here the heading structure is completely flat because of the
[source_file_item] rule. We need to tree-i-fy the flat structure,
by looking at the precedence of the law headings.
*)
let rec law_struct_list_to_tree (f: program_item list) : program_item list =
match f with
| [] -> []
| [item] -> [item]
| first_item::rest ->
let rest_tree = law_struct_list_to_tree rest in
begin match rest_tree with
| [] -> assert false (* there should be at least one rest element *)
| rest_head::rest_tail ->
begin match first_item with
| LawStructure (LawArticle _ | MetadataBlock _ | IntermediateText _) ->
(* if an article or an include is just before a new heading or a new article,
then we don't merge it with what comes next *)
first_item::rest_head::rest_tail
| LawStructure (LawHeading (heading, _)) ->
(* here we have encountered a heading, which is going to "gobble"
everything in the [rest_tree] until it finds a heading of
at least the same precedence *)
let rec split_rest_tree (rest_tree: program_item list)
: law_structure list * program_item list =
match rest_tree with
| [] -> [], []
| (LawStructure (LawHeading (new_heading, _)))::_
when new_heading.law_heading_precedence <= heading.law_heading_precedence
->
(* we stop gobbling *)
[], rest_tree
| (LawStructure first)::after ->
(* we continue gobbling *)
let after_gobbled, after_out = split_rest_tree after in
first::after_gobbled, after_out
in
let gobbled, rest_out = split_rest_tree rest_tree in
(LawStructure (LawHeading (heading, gobbled)))::rest_out
end
end
in
SourceFile (law_struct_list_to_tree f)
}

545
src/catala/catala_surface/parser_errors.ml
View File

@ -4,413 +4,140 @@
let message s =
match s with
| 0 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#0\n"
| 1 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#1\n"
| 5 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#5\n"
| 279 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#275\n"
| 12 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#12\n"
| 13 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#13\n"
| 272 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#268\n"
| 275 -> "Wrong way to begin a code section\n"
| 14 -> "Expecting the constructor for the scope\n"
| 16 -> "Expected a colon after scope constructor\n"
| 158 -> "Expected a rule, a definition or an assertion\n"
| 159 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#18\n"
| 178 -> "Wrong token following an identifier\n"
| 173 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#157\n"
| 164 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#149\n"
| 174 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#158\n"
| 161 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#20\n"
| 167 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#151\n"
| 179 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#61\n"
| 181 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#162\n"
| 182 -> "Only the identifier you wish to define should follow the definition introducing token\n"
| 184 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#165\n"
| 183 -> "Wrong token following function parameter\n"
| 185 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#166\n"
| 188 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#169\n"
| 18 -> "Expected date inside \"|...|\"\n"
| 20 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#24\n"
| 21 -> "Expected date inside \"|...|\"\n"
| 22 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#26\n"
| 23 -> "Expected date inside \"|...|\"\n"
| 24 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#28\n"
| 189 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#170\n"
| 191 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#172\n"
| 192 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#173\n"
| 162 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#21\n"
| 170 -> "Unexpected token after a condition\n"
| 201 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#182\n"
| 90 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#73\n"
| 91 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#74\n"
| 92 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#75\n"
| 93 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#76\n"
| 95 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#78\n"
| 96 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#79\n"
| 51 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#50\n"
| 52 ->
"Missing enumeration case for testing if an enumeration value is in a particular enumeration \
case\n"
| 82 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#87\n"
| 106 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#124\n"
| 54 -> "Invalid function application\n"
| 78 -> "Expected the second term of the comparison\n"
| 87 -> "Expected expression on the right-hand side of multiplication operator\n"
| 84 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#89\n"
| 133 -> "Missing collection for testing whether an element is inside a collection or not\n"
| 100 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#103\n"
| 46 -> "Expected operator or new item after expression\n"
| 49 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#47\n"
| 43 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#44\n"
| 32 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#35\n"
| 140 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#133\n"
| 141 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#134\n"
| 142 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#135\n"
| 148 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#141\n"
| 149 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#142\n"
| 145 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#138\n"
| 151 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#144\n"
| 146 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#139\n"
| 143 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#136\n"
| 33 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#36\n"
| 126 -> "Unmatched parenthesis that should have ended before this\n"
| 55 -> "Expecting an unit for the preceding numeric literal, or an operator\n"
| 35 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#38\n"
| 136 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#127\n"
| 137 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#128\n"
| 138 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#129\n"
| 135 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#126\n"
| 37 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#39\n"
| 112 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#107\n"
| 113 -> "A for all construction expects only one ident\n"
| 114 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#109\n"
| 115 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#110\n"
| 111 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#106\n"
| 197 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#178\n"
| 198 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#179\n"
| 199 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#180\n"
| 120 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#115\n"
| 121 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#116\n"
| 122 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#117\n"
| 123 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#118\n"
| 124 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#119\n"
| 118 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#113\n"
| 62 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#66\n"
| 63 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#67\n"
| 128 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#68\n"
| 42 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#43\n"
| 205 -> "Unexpected token after a scope item\n"
| 208 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#189\n"
| 209 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#190\n"
| 210 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#191\n"
| 211 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#192\n"
| 212 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#193\n"
| 213 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#194\n"
| 214 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#195\n"
| 238 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#219\n"
| 231 -> "Unexpected token, struct scope declaration is over at this point\n"
| 232 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#213\n"
| 228 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#198\n"
| 241 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#222\n"
| 242 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#223\n"
| 243 -> "Scope declarations must have at least one context element\n"
| 244 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#225\n"
| 245 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#226\n"
| 248 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#227\n"
| 249 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#228\n"
| 253 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#250\n"
| 256 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#252\n"
| 257 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#253\n"
| 258 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#254\n"
| 259 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#255\n"
| 260 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#256\n"
| 261 ->
"Unexpected token\n\
To get a better error messsage, file an issue at \
https://github.com/CatalaLang/catala/issues with this parser error token: ERROR#257\n"
| 0 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 1 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 5 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 275 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 278 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 285 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 281 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 13 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 15 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 16 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 17 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 19 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 20 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 21 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 22 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 23 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 45 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 51 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 50 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 81 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 105 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 53 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 77 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 86 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 83 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 132 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 46 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 156 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 48 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 89 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 90 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 91 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 92 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 94 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 95 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 99 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 42 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 31 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 140 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 141 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 147 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 148 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 144 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 150 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 145 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 142 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 139 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 32 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 125 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 54 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 34 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 135 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 136 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 137 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 134 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 36 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 111 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 112 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 113 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 114 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 110 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 119 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 120 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 121 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 122 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 123 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 117 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 61 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 62 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 127 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 63 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 64 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 68 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 69 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 65 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 66 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 41 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 157 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 158 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 177 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 172 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 163 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 173 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 160 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 166 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 178 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 180 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 181 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 183 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 182 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 184 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 187 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 188 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 190 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 191 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 189 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 161 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 169 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 200 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 196 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 197 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 198 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 204 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 207 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 208 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 209 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 210 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 211 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 212 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 213 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 237 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 230 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 231 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 235 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 224 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 227 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 240 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 241 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 242 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 243 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 244 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 245 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 252 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 247 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 248 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 250 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 255 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 256 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 257 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 258 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 259 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 260 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 265 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 11 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 12 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| 271 -> "<YOUR SYNTAX ERROR MESSAGE HERE>\n"
| _ -> raise Not_found

30
src/catala/driver.ml
View File

@ -64,12 +64,6 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
Cli.debug_print
(Printf.sprintf "Weaving literate program into %s"
(match backend with Cli.Latex -> "LaTeX" | Cli.Html -> "HTML" | _ -> assert false));
let weaved_output =
match backend with
| Cli.Latex -> Latex.ast_to_latex program language
| Cli.Html -> Html.ast_to_html program pygmentize_loc language
| _ -> assert false
in
let output_file =
match output_file with
| Some f -> f
@ -77,21 +71,25 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
Filename.remove_extension source_file
^ match backend with Cli.Latex -> ".tex" | Cli.Html -> ".html" | _ -> assert false )
in
let weaved_output =
let oc = open_out output_file in
let weave_output =
match backend with
| Cli.Latex -> Latex.ast_to_latex language
| Cli.Html -> Html.ast_to_html pygmentize_loc language
| _ -> assert false
in
Cli.debug_print (Printf.sprintf "Writing to %s" output_file);
let fmt = Format.formatter_of_out_channel oc in
if wrap_weaved_output then
match backend with
| Cli.Latex ->
Latex.wrap_latex weaved_output program.Catala_ast.program_source_files
pygmentize_loc language
Latex.wrap_latex program.Catala_ast.program_source_files pygmentize_loc language fmt
(fun fmt -> weave_output fmt program)
| Cli.Html ->
Html.wrap_html weaved_output program.Catala_ast.program_source_files pygmentize_loc
language
Html.wrap_html program.Catala_ast.program_source_files pygmentize_loc language fmt
(fun fmt -> weave_output fmt program)
| _ -> assert false
else weaved_output
in
Cli.debug_print (Printf.sprintf "Writing to %s" output_file);
let oc = open_out output_file in
Printf.fprintf oc "%s" weaved_output;
else weave_output fmt program;
close_out oc;
0
| Cli.Run ->

117
src/catala/literate_programming/html.ml
View File

@ -27,20 +27,21 @@ let raise_failed_pygments (command : string) (error_code : int) : 'a =
(Printf.sprintf "Weaving to HTML failed: pygmentize command \"%s\" returned with error code %d"
command error_code)
let wrap_html (code : string) (source_files : string list) (custom_pygments : string option)
(language : Cli.backend_lang) : string =
let wrap_html (source_files : string list) (custom_pygments : string option)
(language : Cli.backend_lang) (fmt : Format.formatter) (wrapped : Format.formatter -> unit) :
unit =
let pygments = match custom_pygments with Some p -> p | None -> "pygmentize" in
let css_file = Filename.temp_file "catala_css_pygments" "" in
let pygments_args = [| "-f"; "html"; "-S"; "colorful"; "-a"; ".catala-code" |] in
let cmd =
Printf.sprintf "%s %s > %s" pygments (String.concat " " (Array.to_list pygments_args)) css_file
Format.sprintf "%s %s > %s" pygments (String.concat " " (Array.to_list pygments_args)) css_file
in
let return_code = Sys.command cmd in
if return_code <> 0 then raise_failed_pygments cmd return_code;
let oc = open_in css_file in
let css_as_string = really_input_string oc (in_channel_length oc) in
close_in oc;
Printf.sprintf
Format.fprintf fmt
"<head>\n\
<style>\n\
%s\n\
@ -55,8 +56,7 @@ let wrap_html (code : string) (source_files : string list) (custom_pygments : st
</p>\n\
<ul>\n\
%s\n\
</ul>\n\
%s"
</ul>\n"
css_as_string
( match language with
| `Fr -> "Implémentation de texte législatif"
@ -81,8 +81,8 @@ let wrap_html (code : string) (source_files : string list) (custom_pygments : st
(pre_html (Filename.basename filename))
(match language with `Fr -> "dernière modification le" | `En -> "last modification")
ftime)
source_files))
code
source_files));
wrapped fmt
let pygmentize_code (c : string Pos.marked) (language : C.backend_lang)
(custom_pygments : string option) : string =
@ -110,7 +110,7 @@ let pygmentize_code (c : string Pos.marked) (language : C.backend_lang)
temp_file_in;
|]
in
let cmd = Printf.sprintf "%s %s" pygments (String.concat " " (Array.to_list pygments_args)) in
let cmd = Format.asprintf "%s %s" pygments (String.concat " " (Array.to_list pygments_args)) in
let return_code = Sys.command cmd in
if return_code <> 0 then raise_failed_pygments cmd return_code;
let oc = open_in temp_file_out in
@ -120,38 +120,11 @@ let pygmentize_code (c : string Pos.marked) (language : C.backend_lang)
type program_state = InsideArticle | OutsideArticle
let program_item_to_html (i : A.program_item) (custom_pygments : string option)
(language : C.backend_lang) (state : program_state) : string * program_state =
let closing_div =
(* First we terminate the div of the previous article if need be *)
match (i, state) with
| (A.LawHeading _ | A.LawArticle _), InsideArticle -> "<!-- Closing article div -->\n</div>\n\n"
| _ -> ""
in
let new_state =
match (i, state) with
| A.LawArticle _, _ -> InsideArticle
| A.LawHeading _, InsideArticle -> OutsideArticle
| _ -> state
in
(* Then we print the actual item *)
let item_string =
let law_article_item_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (i : A.law_article_item) : unit =
match i with
| A.LawHeading (title, precedence) ->
let h_number = precedence + 2 in
P.sprintf "<h%d class='law-heading'>%s</h%d>" h_number (pre_html title) h_number
| A.LawText t -> "<p class='law-text'>" ^ pre_html t ^ "</p>"
| A.LawArticle a ->
P.sprintf
"<div class='article-container'>\n\n<div class='article-title'><a href='%s'>%s</a></div>"
( match (a.law_article_id, language) with
| Some id, `Fr ->
let ltime = Unix.localtime (Unix.time ()) in
P.sprintf "https://beta.legifrance.gouv.fr/codes/id/%s/%d-%02d-%02d" id
(1900 + ltime.Unix.tm_year) (ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday
| _ -> "#" )
(pre_html (Pos.unmark a.law_article_name))
| A.CodeBlock (_, c) | A.MetadataBlock (_, c) ->
| A.LawText t -> Format.fprintf fmt "<p class='law-text'>%s</p>" (pre_html t)
| A.CodeBlock (_, c) ->
let date = "\\d\\d/\\d\\d/\\d\\d\\d\\d" in
let syms = R.regexp (date ^ "|!=|<=|>=|--|->|\\*|\\/") in
let syms_subst = function
@ -165,25 +138,49 @@ let program_item_to_html (i : A.program_item) (custom_pygments : string option)
| s -> s
in
let pprinted_c = R.substitute ~rex:syms ~subst:syms_subst (Pos.unmark c) in
let formatted_original_code =
P.sprintf "<div class='code-wrapper'>\n<div class='filename'>%s</div>\n%s\n</div>"
Format.fprintf fmt "<div class='code-wrapper'>\n<div class='filename'>%s</div>\n%s\n</div>"
(Pos.get_file (Pos.get_position c))
(pygmentize_code
(Pos.same_pos_as ("/*" ^ pprinted_c ^ "*/") c)
language custom_pygments)
in
formatted_original_code
| A.LawInclude _ -> ""
in
(closing_div ^ item_string, new_state)
(pygmentize_code (Pos.same_pos_as ("/*" ^ pprinted_c ^ "*/") c) language custom_pygments)
| A.LawInclude _ -> ()
let ast_to_html (program : A.program) (custom_pygments : string option) (language : C.backend_lang)
: string =
let i_s, _ =
List.fold_left
(fun (acc, state) i ->
let i_s, new_state = program_item_to_html i custom_pygments language state in
(i_s :: acc, new_state))
([], OutsideArticle) program.program_items
in
String.concat "\n\n" (List.rev i_s)
let rec law_structure_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (i : A.law_structure) : unit =
match i with
| A.LawHeading (heading, children) ->
let h_number = heading.law_heading_precedence + 2 in
Format.fprintf fmt "<h%d class='law-heading'>%s</h%d>\n" h_number
(pre_html heading.law_heading_name)
h_number;
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(law_structure_to_html custom_pygments language)
fmt children
| A.LawArticle (a, children) ->
Format.fprintf fmt
"<div class='article-container'>\n\n<div class='article-title'><a href='%s'>%s</a></div>\n"
( match (a.law_article_id, language) with
| Some id, `Fr ->
let ltime = Unix.localtime (Unix.time ()) in
P.sprintf "https://legifrance.gouv.fr/codes/id/%s/%d-%02d-%02d" id
(1900 + ltime.Unix.tm_year) (ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday
| _ -> "#" )
(pre_html (Pos.unmark a.law_article_name));
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(law_article_item_to_html custom_pygments language)
fmt children;
Format.fprintf fmt "\n</div>"
| A.MetadataBlock (b, c) ->
law_article_item_to_html custom_pygments language fmt (A.CodeBlock (b, c))
| A.IntermediateText t -> Format.fprintf fmt "<p class='law-text'>%s</p>" (pre_html t)
let program_item_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (i : A.program_item) : unit =
match i with A.LawStructure s -> law_structure_to_html custom_pygments language fmt s
let ast_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (program : A.program) : unit =
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(program_item_to_html custom_pygments language)
fmt program.program_items

81
src/catala/literate_programming/latex.ml
View File

@ -16,7 +16,6 @@
professionals can understand. *)
module A = Catala_ast
module P = Printf
module R = Re.Pcre
module C = Cli
@ -31,9 +30,9 @@ let pre_latexify (s : string) =
let s = R.substitute ~rex:underscore ~subst:(fun _ -> "\\_") s in
s
let wrap_latex (code : string) (source_files : string list) (custom_pygments : string option)
(language : C.backend_lang) =
Printf.sprintf
let wrap_latex (source_files : string list) (custom_pygments : string option)
(language : C.backend_lang) (fmt : Format.formatter) (wrapped : Format.formatter -> unit) =
Format.fprintf fmt
"\\documentclass[11pt, a4paper]{article}\n\n\
\\usepackage[T1]{fontenc}\n\
\\usepackage[utf8]{inputenc}\n\
@ -73,9 +72,7 @@ let wrap_latex (code : string) (source_files : string list) (custom_pygments : s
\\maketitle\n\n\
%s : \n\
\\begin{itemize}%s\\end{itemize}\n\n\
\\[\\star\\star\\star\\]\\\\\n\
%s\n\n\
\\end{document}"
\\[\\star\\star\\star\\]\\\\\n"
(match language with `Fr -> "french" | `En -> "english")
( match custom_pygments with
| None -> ""
@ -103,8 +100,9 @@ let wrap_latex (code : string) (source_files : string list) (custom_pygments : s
(pre_latexify (Filename.basename filename))
(match language with `Fr -> "dernière modification le" | `En -> "last modification")
ftime)
source_files))
code
source_files));
wrapped fmt;
Format.fprintf fmt "\n\n\\end{document}"
let math_syms_replace (c : string) : string =
let date = "\\d\\d/\\d\\d/\\d\\d\\d\\d" in
@ -121,16 +119,12 @@ let math_syms_replace (c : string) : string =
in
R.substitute ~rex:syms ~subst:syms2cmd c
let program_item_to_latex (i : A.program_item) (language : C.backend_lang) : string =
let law_article_item_to_latex (language : C.backend_lang) (fmt : Format.formatter)
(i : A.law_article_item) : unit =
match i with
| A.LawHeading (title, precedence) ->
P.sprintf "\\%ssection*{%s}"
(match precedence with 0 -> "" | 1 -> "" | 2 -> "sub" | 3 -> "sub" | _ -> "subsub")
(pre_latexify title)
| A.LawText t -> pre_latexify t
| A.LawArticle a -> P.sprintf "\\paragraph{%s}" (pre_latexify (Pos.unmark a.law_article_name))
| A.LawText t -> Format.fprintf fmt "%s" (pre_latexify t)
| A.CodeBlock (_, c) ->
P.sprintf
Format.fprintf fmt
"\\begin{minted}[label={\\hspace*{\\fill}\\texttt{%s}},firstnumber=%d]{%s}\n\
/*%s*/\n\
\\end{minted}"
@ -138,9 +132,40 @@ let program_item_to_latex (i : A.program_item) (language : C.backend_lang) : str
(Pos.get_start_line (Pos.get_position c))
(match language with `Fr -> "catala_fr" | `En -> "catala_en")
(math_syms_replace (Pos.unmark c))
| A.LawInclude (A.PdfFile ((file, _), page)) ->
let label = file ^ match page with None -> "" | Some p -> Format.sprintf "_page_%d," p in
Format.fprintf fmt
"\\begin{center}\\textit{Annexe incluse, retranscrite page \\pageref{%s}}\\end{center} \
\\begin{figure}[p]\\begin{center}\\includegraphics[%swidth=\\textwidth]{%s}\\label{%s}\\end{center}\\end{figure}"
label
(match page with None -> "" | Some p -> Format.sprintf "page=%d," p)
file label
| A.LawInclude (A.CatalaFile _ | A.LegislativeText _) -> ()
let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatter)
(i : A.law_structure) : unit =
match i with
| A.LawHeading (heading, children) ->
Format.fprintf fmt "\\%ssection*{%s}\n\n"
( match heading.law_heading_precedence with
| 0 -> ""
| 1 -> ""
| 2 -> "sub"
| 3 -> "sub"
| _ -> "subsub" )
(pre_latexify heading.law_heading_name);
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(law_structure_to_latex language) fmt children
| A.LawArticle (article, children) ->
Format.fprintf fmt "\\paragraph{%s}\n\n" (pre_latexify (Pos.unmark article.law_article_name));
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(law_article_item_to_latex language)
fmt children
| A.MetadataBlock (_, c) ->
let metadata_title = match language with `Fr -> "Métadonnées" | `En -> "Metadata" in
P.sprintf
Format.fprintf fmt
"\\begin{tcolorbox}[colframe=OliveGreen, breakable, \
title=\\textcolor{black}{\\texttt{%s}},title after \
break=\\textcolor{black}{\\texttt{%s}},before skip=1em, after skip=1em]\n\
@ -153,15 +178,13 @@ let program_item_to_latex (i : A.program_item) (language : C.backend_lang) : str
(pre_latexify (Filename.basename (Pos.get_file (Pos.get_position c))))
(match language with `Fr -> "catala_fr" | `En -> "catala_en")
(math_syms_replace (Pos.unmark c))
| A.LawInclude (A.PdfFile ((file, _), page)) ->
let label = file ^ match page with None -> "" | Some p -> P.sprintf "_page_%d," p in
P.sprintf
"\\begin{center}\\textit{Annexe incluse, retranscrite page \\pageref{%s}}\\end{center} \
\\begin{figure}[p]\\begin{center}\\includegraphics[%swidth=\\textwidth]{%s}\\label{%s}\\end{center}\\end{figure}"
label
(match page with None -> "" | Some p -> P.sprintf "page=%d," p)
file label
| A.LawInclude (A.CatalaFile _ | A.LegislativeText _) -> ""
| A.IntermediateText t -> Format.fprintf fmt "%s" (pre_latexify t)
let ast_to_latex (program : A.program) (language : C.backend_lang) : string =
String.concat "\n\n" (List.map (fun i -> program_item_to_latex i language) program.program_items)
let program_item_to_latex (language : C.backend_lang) (fmt : Format.formatter) (i : A.program_item)
: unit =
match i with A.LawStructure law_s -> law_structure_to_latex language fmt law_s
let ast_to_latex (language : C.backend_lang) (fmt : Format.formatter) (program : A.program) : unit =
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(program_item_to_latex language) fmt program.program_items

7
src/dune
View File

@ -4,10 +4,3 @@
(modules catala)
(public_name catala)
(libraries catala))
(executable
(name legifrance_catala)
(package legifrance_catala)
(modules legifrance_catala)
(public_name legifrance_catala)
(libraries legifrance_catala))

208
src/legifrance_catala/api.ml
View File

@ -1,208 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 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 Lwt
type access_token = string
let get_token_aux (client_id : string) (client_secret : string) : (string * string t) t =
let site = "https://oauth.aife.economie.gouv.fr" in
let token_url = "/api/oauth/token" in
let uri = Uri.of_string (site ^ token_url) in
let headers = Cohttp.Header.init_with "Content-Type" "application/x-www-form-urlencoded" in
let body_string =
[
("grant_type", "client_credentials");
("client_id", client_id);
("client_secret", client_secret);
("scope", "openid");
]
|> List.map (fun (k, v) -> Printf.sprintf {|%s=%s|} k v)
|> String.concat "&" |> Printf.sprintf "%s"
in
let body = body_string |> Cohttp_lwt.Body.of_string in
Cohttp_lwt_unix.Client.post ~headers ~body uri >>= fun (resp, body) ->
( resp |> Cohttp_lwt.Response.status |> Cohttp.Code.string_of_status,
body |> Cohttp_lwt.Body.to_string )
|> return
let get_token (client_id : string) (client_secret : string) : string =
let resp, body = Lwt_main.run (get_token_aux client_id client_secret) in
let body = Lwt_main.run body in
if resp = "200 OK" then begin
let token =
body |> Yojson.Basic.from_string
|> Yojson.Basic.Util.member "access_token"
|> Yojson.Basic.Util.to_string
in
Catala.Cli.debug_print (Printf.sprintf "The LegiFrance API access token is %s" token);
token
end
else begin
Catala.Cli.debug_print
(Printf.sprintf "The API access token request went wrong ; status is %s and the body is\n%s"
resp body);
exit 1
end
let site = "https://api.aife.economie.gouv.fr"
let base_token_url = "/dila/legifrance-beta/lf-engine-app/"
let api_timestamp_to_localtime (timestamp : int) : Unix.tm =
Unix.localtime (float_of_int (timestamp / 1000))
let make_request (access_token : string) (token_url : string) (body_json : (string * string) list) :
(string * string t) t =
let uri = Uri.of_string (site ^ base_token_url ^ token_url) in
let headers = Cohttp.Header.init_with "Authorization" (Printf.sprintf "Bearer %s" access_token) in
let headers = Cohttp.Header.add headers "Content-Type" "application/json" in
let headers = Cohttp.Header.add headers "Accept" "application/json" in
let body_string =
body_json
|> List.map (fun (k, v) -> Printf.sprintf {|"%s":"%s"|} k v)
|> String.concat "," |> Printf.sprintf "{%s}"
in
let body = body_string |> Cohttp_lwt.Body.of_string in
Cohttp_lwt_unix.Client.post ~headers ~body uri >>= fun (resp, body) ->
( resp |> Cohttp_lwt.Response.status |> Cohttp.Code.string_of_status,
body |> Cohttp_lwt.Body.to_string )
|> return
type article = Yojson.Basic.t
let run_request (request : (string * string t) t) : Yojson.Basic.t =
let resp, body = Lwt_main.run request in
let body = Lwt_main.run body in
if resp = "200 OK" then (
try body |> Yojson.Basic.from_string
with Yojson.Basic.Util.Type_error (msg, obj) ->
Catala.Cli.error_print
(Printf.sprintf
"Error while parsing JSON answer from API: %s\nSpecific JSON:\n%s\nFull answer:\n%s" msg
(Yojson.Basic.to_string obj) body);
exit (-1) )
else begin
Catala.Cli.error_print
(Printf.sprintf "The API request went wrong ; status is %s and the body is\n%s" resp body);
exit (-1)
end
let retrieve_article (access_token : string) (article_id : string) : Yojson.Basic.t =
run_request (make_request access_token "consult/getArticle" [ ("id", article_id) ])
let raise_article_parsing_error (json : Yojson.Basic.t) (msg : string) (obj : Yojson.Basic.t) =
Catala.Cli.error_print
(Printf.sprintf
"Error while manipulating JSON answer from API: %s\nSpecific JSON:\n%s\nFull answer:\n%s" msg
(Yojson.Basic.to_string obj) (Yojson.Basic.to_string json));
exit 1
type law_excerpt = Yojson.Basic.t
let retrieve_law_excerpt (access_token : string) (text_id : string) : law_excerpt =
run_request (make_request access_token "consult/jorfPart" [ ("textCid", text_id) ])
let get_article_id (json : article) : string =
try
json
|> Yojson.Basic.Util.member "article"
|> Yojson.Basic.Util.member "id" |> Yojson.Basic.Util.to_string
with Yojson.Basic.Util.Type_error (msg, obj) -> raise_article_parsing_error json msg obj
let get_article_text (json : article) : string =
try
let text =
json
|> Yojson.Basic.Util.member "article"
|> Yojson.Basic.Util.member "texte" |> Yojson.Basic.Util.to_string
in
(* there might be a nota *)
let nota =
try
json
|> Yojson.Basic.Util.member "article"
|> Yojson.Basic.Util.member "nota" |> Yojson.Basic.Util.to_string
with Yojson.Basic.Util.Type_error _ -> ""
in
text ^ " " ^ if nota <> "" then "NOTA : " ^ nota else ""
with Yojson.Basic.Util.Type_error (msg, obj) -> raise_article_parsing_error json msg obj
let get_article_expiration_date (json : article) : Unix.tm =
try
let article_id = get_article_id json in
json
|> Yojson.Basic.Util.member "article"
|> Yojson.Basic.Util.member "articleVersions"
|> Yojson.Basic.Util.to_list
|> List.find (fun version ->
Yojson.Basic.to_string (Yojson.Basic.Util.member "id" version) = "\"" ^ article_id ^ "\"")
|> Yojson.Basic.Util.member "dateFin"
|> Yojson.Basic.Util.to_int |> api_timestamp_to_localtime
with Yojson.Basic.Util.Type_error (msg, obj) -> raise_article_parsing_error json msg obj
let get_article_new_version (json : article) : string =
let expiration_date = get_article_expiration_date json in
let get_version_date_debut (version : Yojson.Basic.t) : Unix.tm =
version
|> Yojson.Basic.Util.member "dateDebut"
|> Yojson.Basic.Util.to_int |> api_timestamp_to_localtime
in
try
json
|> Yojson.Basic.Util.member "article"
|> Yojson.Basic.Util.member "articleVersions"
|> Yojson.Basic.Util.to_list
|> List.filter (fun version ->
Date.date_compare expiration_date (get_version_date_debut version) <= 0)
|> List.sort (fun version1 version2 ->
Date.date_compare (get_version_date_debut version1) (get_version_date_debut version2))
|> List.hd |> Yojson.Basic.Util.member "id" |> Yojson.Basic.Util.to_string
with Yojson.Basic.Util.Type_error (msg, obj) -> raise_article_parsing_error json msg obj
let get_law_excerpt_title (json : law_excerpt) : string =
json |> Yojson.Basic.Util.member "title" |> Yojson.Basic.Util.to_string
type law_excerpt_article = { id : string; num : string; content : string }
let clean_html (s : string) : string =
let new_line = Re.Pcre.regexp "\\s*\\<br\\s*\\/\\>\\s*" in
let s = Re.Pcre.substitute ~rex:new_line ~subst:(fun _ -> "\n") s in
let tag = Re.Pcre.regexp "\\<[^\\>]+\\>" in
let s = Re.Pcre.substitute ~rex:tag ~subst:(fun _ -> "") s in
String.trim s
let get_law_excerpt_articles (json : law_excerpt) : law_excerpt_article list =
let articles = json |> Yojson.Basic.Util.member "articles" |> Yojson.Basic.Util.to_list in
let articles =
List.sort
(fun a1 a2 ->
let a1_num =
int_of_string (a1 |> Yojson.Basic.Util.member "num" |> Yojson.Basic.Util.to_string)
in
let a2_num =
int_of_string (a2 |> Yojson.Basic.Util.member "num" |> Yojson.Basic.Util.to_string)
in
compare a1_num a2_num)
articles
in
List.map
(fun article ->
let article_id = article |> Yojson.Basic.Util.member "id" |> Yojson.Basic.Util.to_string in
let article_num = article |> Yojson.Basic.Util.member "num" |> Yojson.Basic.Util.to_string in
let article_content =
article |> Yojson.Basic.Util.member "content" |> Yojson.Basic.Util.to_string |> clean_html
in
{ id = article_id; num = article_num; content = article_content })
articles

57
src/legifrance_catala/api.mli
View File

@ -1,57 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 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. *)
(** Performs API requests and manipulates API data. Needs a working Internet connection to work *)
(** {2 Requests}*)
type access_token
(** The [access_token] is the OAuth token used in every API request for authentication *)
val get_token : string -> string -> access_token
(** [get_token cliend_id client_secret] retrieves the access token from the LegiFrance API. You have
to register on the {{:https://developer.aife.economie.gouv.fr/} the official website of the
French government} to get your OAuth client ID and Secret for the LegiFrance API *)
type article
val retrieve_article : access_token -> string -> article
(** [retrieve_article token article_id] returns the article from the LegiFrance API. [article_id]
should be of the form ["LEGIARTI000006307920"] *)
type law_excerpt
val retrieve_law_excerpt : access_token -> string -> law_excerpt
(**[retrieve_law_excerpt token excerpt_id] returns a whole excerpt of a legislative statute from the
LegiFrance API. [excerpt_id] should be of the form ["JORFTEXT000033736934"] *)
(**{2 Manipulating API objects}*)
(**{3 Articles}*)
val get_article_id : article -> string
val get_article_text : article -> string
val get_article_expiration_date : article -> Unix.tm
val get_article_new_version : article -> string
(**{3 Law excerpts}*)
val get_law_excerpt_title : law_excerpt -> string
type law_excerpt_article = { id : string; num : string; content : string }
val get_law_excerpt_articles : law_excerpt -> law_excerpt_article list

59
src/legifrance_catala/cli.ml
View File

@ -1,59 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 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. *)
(** Command line arguments specification of [legifrance_catala] *)
open Cmdliner
let file =
Arg.(
required
& pos 0 (some string) None
& info [] ~docv:"FILE"
~doc:"Name of the Catala master file you want to get LegiFrance information on")
let client_id =
Arg.(
required
& pos 1 (some string) None
& info [] ~docv:"CLIENT_ID" ~doc:"LegiFrance Oauth cliend id")
let client_secret =
Arg.(
required
& pos 2 (some string) None
& info [] ~docv:"CLIENT_SECRET" ~doc:"LegiFrance Oauth cliend secret")
let debug = Arg.(value & flag & info [ "d"; "debug" ] ~doc:"Prints debug information")
(** Arguments : [file debug cliend_id client_secret] *)
let catala_legifrance_t f = Term.(const f $ file $ debug $ client_id $ client_secret)
let info =
let doc = "LegiFrance interaction tool for Catala" in
let man =
[
`S Manpage.s_authors;
`P "Denis Merigoux <denis.merigoux@inria.fr>";
`S Manpage.s_bugs;
`P "Please file bug reports at https://gitlab.inria.fr/verifisc/catala/issues";
]
in
let exits = Term.default_exits @ [ Term.exit_info ~doc:"on error" 1 ] in
Term.info "legifrance_catala"
~version:
( match Build_info.V1.version () with
| None -> "n/a"
| Some v -> Build_info.V1.Version.to_string v )
~doc ~exits ~man

52
src/legifrance_catala/date.ml
View File

@ -1,52 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 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. *)
(** Helper functions to interact with {!Unix.tm} dates *)
(** Parses a date formatted as [DD/MM/YYYY] into an {!Unix.tm}*)
let parse_expiration_date (expiration_date : string) : Unix.tm =
try
let extract_article_title = Re.Pcre.regexp "([0-9]{2})\\/([0-9]{2})\\/([0-9]{4})" in
let get_substring =
Re.Pcre.get_substring (Re.Pcre.exec ~rex:extract_article_title expiration_date)
in
snd
(Unix.mktime
{
Unix.tm_mday = int_of_string (get_substring 1);
Unix.tm_mon = int_of_string (get_substring 2);
Unix.tm_year = int_of_string (get_substring 3) - 1900;
Unix.tm_sec = 0;
Unix.tm_min = 0;
Unix.tm_hour = 0;
Unix.tm_wday = 0;
Unix.tm_yday = 0;
Unix.tm_isdst = false;
})
with _ ->
Catala.Cli.error_print
(Printf.sprintf "Error while parsing expiration date argument (%s)" expiration_date);
exit 0
(** Prints an [Unix.tm] under the ISO formatting [YYYY-MM-DD] *)
let print_tm (d : Unix.tm) : string =
if d.Unix.tm_year + 1900 = 2999 then "undefined date"
else Printf.sprintf "%d-%02d-%02d" (1900 + d.Unix.tm_year) (1 + d.Unix.tm_mon) d.Unix.tm_mday
(** Returns true if [d] is set in the year [2999] *)
let is_infinity (d : Unix.tm) : bool = d.Unix.tm_year + 1900 = 2999
(** [date_compare d1 d2] compares the timestamps of [d1] and [d2]*)
let date_compare (d1 : Unix.tm) (d2 : Unix.tm) : int =
int_of_float (fst (Unix.mktime d1)) - int_of_float (fst (Unix.mktime d2))

96
src/legifrance_catala/diff.ml
View File

@ -1,96 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 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. *)
module type Comparable = sig
type t
val compare : t -> t -> int
end
module Make (X : Comparable) = struct
type item = X.t
type diff = Deleted of item list | Added of item list | Equal of item list
type t = diff list
module ResultTable = Map.Make (struct
type t = int * int
let compare (x1, x2) (y1, y2) = if x1 = y1 then x2 - y2 else x1 - y1
end)
(* TODO: optimize this ! *)
let rec longest_common_subsequence (results : item list ResultTable.t) (x1 : item array)
(x2 : item array) (i1 : int) (i2 : int) : item list * item list ResultTable.t =
if ResultTable.mem (i1, i2) results then (ResultTable.find (i1, i2) results, results)
else if i1 = 0 || i2 = 0 then ([], ResultTable.add (0, 0) [] results)
else if X.compare x1.(i1 - 1) x2.(i2 - 1) = 0 then
let res, new_results = longest_common_subsequence results x1 x2 (i1 - 1) (i2 - 1) in
let res = res @ [ x1.(i1 - 1) ] in
(res, ResultTable.add (i1, i2) res new_results)
else
let res1, new_results1 = longest_common_subsequence results x1 x2 (i1 - 1) i2 in
let res2, new_results2 = longest_common_subsequence new_results1 x1 x2 i1 (i2 - 1) in
let res = if List.length res1 > List.length res2 then res1 else res2 in
(res, ResultTable.add (i1, i2) res new_results2)
let rec get_diff_aux (x1 : item array) (x2 : item array) (i1 : int) (i2 : int) (lcs : item list) :
diff list =
if i1 >= Array.length x1 && i2 >= Array.length x2 then [ Equal [] ]
else if i1 >= Array.length x1 then
[ Added (Array.to_list (Array.sub x2 i2 (Array.length x2 - i2))) ]
else if i2 >= Array.length x2 then
[ Deleted (Array.to_list (Array.sub x1 i1 (Array.length x1 - i1))) ]
else
match lcs with
| [] ->
[
Deleted (Array.to_list (Array.sub x1 i1 (Array.length x1 - i1)));
Added (Array.to_list (Array.sub x2 i2 (Array.length x2 - i2)));
]
| hd :: lcs_rest ->
if X.compare x1.(i1) hd = 0 && X.compare x2.(i2) hd = 0 then
Equal [ hd ] :: get_diff_aux x1 x2 (i1 + 1) (i2 + 1) lcs_rest
else if X.compare x1.(i1) hd = 0 then
Added [ x2.(i2) ] :: get_diff_aux x1 x2 i1 (i2 + 1) lcs
else if X.compare x2.(i2) hd = 0 then
Deleted [ x1.(i1) ] :: get_diff_aux x1 x2 (i1 + 1) i2 lcs
else
let after = get_diff_aux x1 x2 (i1 + 1) (i2 + 1) lcs in
Deleted [ x1.(i1) ] :: Added [ x2.(i2) ] :: after
let compress_t (x : t) : t =
List.rev
(List.fold_left
(fun (acc : t) (diff : diff) ->
match (acc, diff) with
| [], _ -> [ diff ]
| Added x1 :: rest_acc, Added x2 -> Added (x1 @ x2) :: rest_acc
| Deleted x1 :: rest_acc, Deleted x2 -> Deleted (x1 @ x2) :: rest_acc
| Equal x1 :: rest_acc, Equal x2 -> Equal (x1 @ x2) :: rest_acc
| Added x1 :: Deleted x2 :: rest_acc, Deleted x3 ->
Deleted (x2 @ x3) :: Added x1 :: rest_acc
| Deleted x1 :: Added x2 :: rest_acc, Added x3 ->
Added (x2 @ x3) :: Deleted x1 :: rest_acc
| _ -> diff :: acc)
[] x)
let get_diff (x1 : item array) (x2 : item array) : t =
let lcs, _ =
longest_common_subsequence ResultTable.empty x1 x2 (Array.length x1) (Array.length x2)
in
let out = get_diff_aux x1 x2 0 0 lcs in
compress_t out
end

35
src/legifrance_catala/diff.mli
View File

@ -1,35 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 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. *)
(** Simple and inefficient diff algorithm based on longest common subsequences *)
(** The diff algorithm works on comparable items *)
module type Comparable = sig
type t
val compare : t -> t -> int
end
(** Functor that produces a [Diff] module given a comparable type *)
module Make : functor (X : Comparable) -> sig
type item = X.t
type diff = Deleted of item list | Added of item list | Equal of item list
type t = diff list
val get_diff : item array -> item array -> t
(** This is the main function : [get_diff a1 a2] compares two arrays of items and outputs a list
of chunks tagged with [Deteted], [Added] or [Removed] *)
end

6
src/legifrance_catala/dune
View File

@ -1,6 +0,0 @@
(library
(public_name legifrance_catala)
(libraries catala cmdliner cohttp lwt cohttp-lwt-unix yojson re ANSITerminal))
(documentation
(package legifrance_catala))

219
src/legifrance_catala/main.ml
View File

@ -1,219 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 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. *)
(** Main logic for interacting with LegiFrance when traversing Catala source files *)
type new_article_version = NotAvailable | Available of string
(** Returns the ID of the future version of the article if any *)
let check_article_expiration (article_catala : Catala.Catala_ast.law_article)
(access_token : Api.access_token) : new_article_version option =
match article_catala.Catala.Catala_ast.law_article_id with
| None -> None
| Some article_id ->
let article = Api.retrieve_article access_token article_id in
let api_article_expiration_date = Api.get_article_expiration_date article in
let msg =
Printf.sprintf "%s %s expires on %s according to LegiFrance%s"
(Catala.Pos.unmark article_catala.Catala.Catala_ast.law_article_name)
(Catala.Pos.to_string
(Catala.Pos.get_position article_catala.Catala.Catala_ast.law_article_name))
(Date.print_tm api_article_expiration_date)
( match article_catala.Catala.Catala_ast.law_article_expiration_date with
| None -> ""
| Some source_exp_date -> ", " ^ source_exp_date ^ " according to source code" )
in
let new_version_available = not (Date.is_infinity api_article_expiration_date) in
let source_code_expiration =
match article_catala.Catala.Catala_ast.law_article_expiration_date with
| None -> false
| Some source_exp_date ->
let source_exp_date = Date.parse_expiration_date source_exp_date in
not (Date.is_infinity source_exp_date)
in
if new_version_available || source_code_expiration then begin
Catala.Cli.warning_print msg;
if new_version_available then begin
let new_version = Api.get_article_new_version article in
Catala.Cli.debug_print (Printf.sprintf "New version of the article: %s" new_version);
Some (Available new_version)
end
else Some NotAvailable
end
else begin
Catala.Cli.debug_print msg;
None
end
type article_text_acc = {
article_title : string Catala.Pos.marked;
text : string;
new_version : string option;
current_version : string option;
}
(** Accumulator type when traversing the Catala source files *)
module Diff = Diff.Make (String)
(** Diff algorithm for a list of words *)
(** [compare_article_to_version token text version] retrieves the text of the article whose
LegiFrance ID is [version] and produces a diff with the expected [text]*)
let compare_article_to_version (access_token : Api.access_token) (text : string) (version : string)
: Diff.t option =
let new_article = Api.retrieve_article access_token version in
let new_article_text = Api.get_article_text new_article in
let text_to_list text = List.filter (fun word -> word <> "") (String.split_on_char ' ' text) in
let old_list = text_to_list text in
let new_list = text_to_list new_article_text in
let diff = Diff.get_diff (Array.of_list old_list) (Array.of_list new_list) in
let all_equal =
List.for_all (fun chunk -> match chunk with Diff.Equal _ -> true | _ -> false) diff
in
if not all_equal then Some diff else None
(** Compares [article_text_acc.current_version] and [article_text_acc.new_version] by accessing
LegiFrance and display differences if any *)
let compare_to_versions (article_text_acc : article_text_acc) (access_token : Api.access_token) :
unit =
let print_diff msg diff =
Catala.Cli.warning_print
(Printf.sprintf "%s\n%s" msg
(String.concat "\n"
(List.map
(fun chunk ->
match chunk with
| Diff.Equal words -> ANSITerminal.sprintf [] "%s" (String.concat " " words)
| Diff.Added words ->
ANSITerminal.sprintf [ ANSITerminal.green ] "(+) %s" (String.concat " " words)
| Diff.Deleted words ->
ANSITerminal.sprintf [ ANSITerminal.red ] "(-) %s" (String.concat " " words))
diff)))
in
begin
match article_text_acc.current_version with
| Some version -> (
match compare_article_to_version access_token article_text_acc.text version with
| None -> ()
| Some diff ->
print_diff
(Printf.sprintf
"There is a diff between the source code version of %s %s and the text stored on \
LegiFrance:"
(Catala.Pos.unmark article_text_acc.article_title)
(Catala.Pos.to_string (Catala.Pos.get_position article_text_acc.article_title)))
diff )
| None -> ()
end;
match article_text_acc.new_version with
| Some version -> (
match compare_article_to_version access_token article_text_acc.text version with
| None -> ()
| Some diff ->
print_diff
(Printf.sprintf
"Here is the diff between the current version of %s %s and what it will become in \
the future:"
(Catala.Pos.unmark article_text_acc.article_title)
(Catala.Pos.to_string (Catala.Pos.get_position article_text_acc.article_title)))
diff )
| None -> ()
(** Fill an [@@Include ...@@] tag inside the Catala source file with the legislative contents
retrieved from LegiFrance *)
let include_legislative_text (id : string Catala.Pos.marked) (access_token : Api.access_token) :
unit =
let excerpt = Api.retrieve_law_excerpt access_token (Catala.Pos.unmark id) in
let title = "@@" ^ Api.get_law_excerpt_title excerpt ^ "@@" in
let articles =
List.map
(fun article ->
Printf.sprintf "@Article %s|%s@\n%s" article.Api.num article.Api.id article.Api.content)
(Api.get_law_excerpt_articles excerpt)
in
let to_insert = title ^ "\n\n" ^ String.concat "\n\n" articles in
let pos = Catala.Pos.get_position id in
Catala.Cli.debug_print (Printf.sprintf "Position: %s" (Catala.Pos.to_string pos));
let file = Catala.Pos.get_file pos in
let include_line = Catala.Pos.get_end_line pos in
let ic = open_in file in
let new_file = file ^ ".new" in
Catala.Cli.warning_print
(Printf.sprintf "LegiFrance inclusion detected, writing new contents to %s" new_file);
let oc = open_out new_file in
(* Pos.t lines start at 1 *)
let counter = ref 1 in
try
while true do
let line = input_line ic in
if include_line = !counter then Printf.fprintf oc "%s\n" to_insert
else Printf.fprintf oc "%s\n" line;
counter := !counter + 1
done
with End_of_file ->
close_in ic;
close_out oc
(** Parses the Catala master source file and checks each article:
- if the article has a LegiFrance ID, checks the text of the article in the source code vs the
text from LegiFrance;
- if the article has an expiration date, display the difference between the current version of
the article and the next one on LegiFrance;
- fill each [@@Include ...@@] tag with the contents retrieved from LegiFrance *)
let driver (file : string) (debug : bool) (client_id : string) (client_secret : string) =
if debug then Catala.Cli.debug_flag := true;
let access_token = Api.get_token client_id client_secret in
(* LegiFrance is only supported for French texts *)
let program = Catala.Parser_driver.parse_source_files [ file ] `Fr in
let article_text_acc =
List.fold_left
(fun article_text_acc item ->
match item with
| Catala.Catala_ast.LawArticle article_catala -> (
compare_to_versions article_text_acc access_token;
let new_version = check_article_expiration article_catala access_token in
match new_version with
| Some (Available version) ->
{
article_title = article_catala.law_article_name;
text = "";
new_version = Some version;
current_version = article_catala.Catala.Catala_ast.law_article_id;
}
| _ ->
{
article_title = article_catala.law_article_name;
text = "";
new_version = None;
current_version = article_catala.Catala.Catala_ast.law_article_id;
} )
| Catala.Catala_ast.LawText art_text ->
{ article_text_acc with text = article_text_acc.text ^ " " ^ art_text }
| Catala.Catala_ast.LawInclude (Catala.Catala_ast.LegislativeText id) ->
include_legislative_text id access_token;
article_text_acc
| _ -> article_text_acc)
{
article_title = ("", Catala.Pos.no_pos);
text = "";
new_version = None;
current_version = None;
}
program.program_items
in
compare_to_versions article_text_acc access_token;
exit 0
(** Hook for the executable *)
let main () = Cmdliner.Term.exit @@ Cmdliner.Term.eval (Cli.catala_legifrance_t driver, Cli.info)

2
tests/test_bool/test_bool.catala
View File

@ -1,3 +1,5 @@
@Article@
/*
new scope TestBool :
param foo type bool

2
tests/test_func/func.catala
View File

@ -1,3 +1,5 @@
@Article@
/*
new scope S:
param f type int fun of int

2
tests/test_scope/scope.catala
View File

@ -1,3 +1,5 @@
@Article@
/*
new scope A:
param a type int

6
tests/test_scope/scope.catala.A.out
View File

@ -3,17 +3,17 @@
[ERROR] The conflict concerns this variable b
[ERROR] --> test_scope/scope.catala
[ERROR] |
[ERROR] 4 | param b type dec
[ERROR] 6 | param b type dec
[ERROR] | ^
[ERROR]
[ERROR] This justification is true:
[ERROR] --> test_scope/scope.catala
[ERROR] |
[ERROR] 11 | def b [ not c ] := 1337
[ERROR] 13 | def b [ not c ] := 1337
[ERROR] | ^^^^^
[ERROR]
[ERROR] This justification is true:
[ERROR] --> test_scope/scope.catala
[ERROR] |
[ERROR] 12 | def b [ not c ] := 0
[ERROR] 14 | def b [ not c ] := 0
[ERROR] | ^^^^^

2
tests/test_scope/sub_scope.catala
View File

@ -1,3 +1,5 @@
@Article@
/*
new scope A:
param a type int

2
tests/test_scope/sub_sub_scope.catala
View File

@ -1,3 +1,5 @@
@Article@
/*
new scope A:
param x type int

6
tests/test_scope/sub_sub_scope.catala.B.out
View File

@ -3,17 +3,17 @@
[ERROR] The conflict concerns this variable y
[ERROR] --> test_scope/sub_sub_scope.catala
[ERROR] |
[ERROR] 8 | param y type int
[ERROR] 10 | param y type int
[ERROR] | ^
[ERROR]
[ERROR] This justification is true:
[ERROR] --> test_scope/sub_sub_scope.catala
[ERROR] |
[ERROR] 21 | def y [ a.x = 1 ] := 1
[ERROR] 23 | def y [ a.x = 1 ] := 1
[ERROR] | ^^^^^^^
[ERROR]
[ERROR] This justification is true:
[ERROR] --> test_scope/sub_sub_scope.catala
[ERROR] |
[ERROR] 22 | def y [ a.x + 1 = 2 ] := 1
[ERROR] 24 | def y [ a.x + 1 = 2 ] := 1
[ERROR] | ^^^^^^^^^^^