balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'rinderknecht@code_inclusion' into 'dev'

Browse Source 
Improved code injection

See merge request ligolang/ligo!680
This commit is contained in:
Christian Rinderknecht 2020-06-22 19:36:45 +00:00
commit fb4a888867
26 changed files with 2943 additions and 2999 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
src/passes/01-parser/cameligo/AST.ml
View File

@ -227,27 +227,27 @@ and field_pattern = {
} }
and expr = and expr =
ECase of expr case reg ECase of expr case reg
| ECond of cond_expr reg | ECond of cond_expr reg
| EAnnot of annot_expr par reg | EAnnot of annot_expr par reg
| ELogic of logic_expr | ELogic of logic_expr
| EArith of arith_expr | EArith of arith_expr
| EString of string_expr | EString of string_expr
| EList of list_expr | EList of list_expr
| EConstr of constr_expr | EConstr of constr_expr
| ERecord of record reg | ERecord of record reg
| EProj of projection reg | EProj of projection reg
| EUpdate of update reg | EUpdate of update reg
| EVar of variable | EVar of variable
| ECall of (expr * expr nseq) reg | ECall of (expr * expr nseq) reg
| EBytes of (string * Hex.t) reg | EBytes of (string * Hex.t) reg
| EUnit of the_unit reg | EUnit of the_unit reg
| ETuple of (expr, comma) nsepseq reg | ETuple of (expr, comma) nsepseq reg
| EPar of expr par reg | EPar of expr par reg
| ELetIn of let_in reg | ELetIn of let_in reg
| EFun of fun_expr reg | EFun of fun_expr reg
| ESeq of expr injection reg | ESeq of expr injection reg
| ECodeInsert of code_insert reg | ECodeInj of code_inj reg
and annot_expr = expr * colon * type_expr and annot_expr = expr * colon * type_expr
@ -400,13 +400,16 @@ and cond_expr = {
ifnot : expr ifnot : expr
} }
and code_insert = { (* Code injection. Note how the field [language] wraps a region in
lbracket : lbracket; another: the outermost region covers the header "[%<language>" and
percent : percent; the innermost covers the <language>. *)
language : string reg;
code : expr; and code_inj = {
rbracket : rbracket; language : string reg reg;
code : expr;
rbracket : rbracket;
} }
(* Projecting regions from some nodes of the AST *) (* Projecting regions from some nodes of the AST *)
let rec last to_region = function let rec last to_region = function
@ -491,7 +494,7 @@ let expr_to_region = function
| ECall {region;_} | EVar {region; _} | EProj {region; _} | ECall {region;_} | EVar {region; _} | EProj {region; _}
| EUnit {region;_} | EPar {region;_} | EBytes {region; _} | EUnit {region;_} | EPar {region;_} | EBytes {region; _}
| ESeq {region; _} | ERecord {region; _} | EUpdate {region; _} | ESeq {region; _} | ERecord {region; _} | EUpdate {region; _}
| ECodeInsert {region; _} -> region | ECodeInj {region; _} -> region
let declaration_to_region = function let declaration_to_region = function
| Let {region;_} | Let {region;_}

31
src/passes/01-parser/cameligo/LexToken.mli
View File

@ -29,9 +29,22 @@ type lexeme = string
(* TOKENS *) (* TOKENS *)
type t = type t =
(* Symbols *) (* Identifiers, labels, numbers and strings *)
ARROW of Region.t (* "->" *) Ident of string Region.reg
| Constr of string Region.reg
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Verbatim of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
| Lang of lexeme Region.reg Region.reg
(* Symbols *)
| ARROW of Region.t (* "->" *)
| CONS of Region.t (* "::" *) | CONS of Region.t (* "::" *)
| CAT of Region.t (* "^" *) | CAT of Region.t (* "^" *)
(*| APPEND (* "@" *)*) (*| APPEND (* "@" *)*)
@ -42,7 +55,6 @@ type t =
| PLUS of Region.t (* "+" *) | PLUS of Region.t (* "+" *)
| SLASH of Region.t (* "/" *) | SLASH of Region.t (* "/" *)
| TIMES of Region.t (* "*" *) | TIMES of Region.t (* "*" *)
| PERCENT of Region.t (* "%" *)
(* Compounds *) (* Compounds *)
@ -77,18 +89,6 @@ type t =
| BOOL_OR of Region.t (* "||" *) | BOOL_OR of Region.t (* "||" *)
| BOOL_AND of Region.t (* "&&" *) | BOOL_AND of Region.t (* "&&" *)
(* Identifiers, labels, numbers and strings *)
| Ident of string Region.reg
| Constr of string Region.reg
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Verbatim of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
(* Keywords *) (* Keywords *)
(*| And*) (*| And*)
@ -155,6 +155,7 @@ val mk_verbatim : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token
val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result
val mk_lang : lexeme Region.reg -> Region.t -> token
val eof : Region.t -> token val eof : Region.t -> token
(* Predicates *) (* Predicates *)

60
src/passes/01-parser/cameligo/LexToken.mll
View File

@ -13,9 +13,22 @@ module SSet = Utils.String.Set
(* TOKENS *) (* TOKENS *)
type t = type t =
(* Identifiers, labels, numbers and strings *)
Ident of string Region.reg
| Constr of string Region.reg
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Verbatim of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
| Lang of lexeme Region.reg Region.reg
(* Symbols *) (* Symbols *)
ARROW of Region.t (* "->" *) | ARROW of Region.t (* "->" *)
| CONS of Region.t (* "::" *) | CONS of Region.t (* "::" *)
| CAT of Region.t (* "^" *) | CAT of Region.t (* "^" *)
(*| APPEND (* "@" *)*) (*| APPEND (* "@" *)*)
@ -26,7 +39,6 @@ type t =
| PLUS of Region.t (* "+" *) | PLUS of Region.t (* "+" *)
| SLASH of Region.t (* "/" *) | SLASH of Region.t (* "/" *)
| TIMES of Region.t (* "*" *) | TIMES of Region.t (* "*" *)
| PERCENT of Region.t (* "%" *)
(* Compounds *) (* Compounds *)
@ -61,18 +73,6 @@ type t =
| BOOL_OR of Region.t (* "||" *) | BOOL_OR of Region.t (* "||" *)
| BOOL_AND of Region.t (* "&&" *) | BOOL_AND of Region.t (* "&&" *)
(* Identifiers, labels, numbers and strings *)
| Ident of string Region.reg
| Constr of string Region.reg
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Verbatim of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
(* Keywords *) (* Keywords *)
(*| And*) (*| And*)
@ -113,26 +113,28 @@ let proj_token = function
(* Literals *) (* Literals *)
String Region.{region; value} -> String Region.{region; value} ->
region, sprintf "String %s" value region, sprintf "String %S" value
| Verbatim Region.{region; value} -> | Verbatim Region.{region; value} ->
region, sprintf "Verbatim {|%s|}" value region, sprintf "Verbatim %S" value
| Bytes Region.{region; value = s,b} -> | Bytes Region.{region; value = s,b} ->
region, region,
sprintf "Bytes (\"%s\", \"0x%s\")" s (Hex.show b) sprintf "Bytes (%S, \"0x%s\")" s (Hex.show b)
| Int Region.{region; value = s,n} -> | Int Region.{region; value = s,n} ->
region, sprintf "Int (\"%s\", %s)" s (Z.to_string n) region, sprintf "Int (%S, %s)" s (Z.to_string n)
| Nat Region.{region; value = s,n} -> | Nat Region.{region; value = s,n} ->
region, sprintf "Nat (\"%s\", %s)" s (Z.to_string n) region, sprintf "Nat (%S, %s)" s (Z.to_string n)
| Mutez Region.{region; value = s,n} -> | Mutez Region.{region; value = s,n} ->
region, sprintf "Mutez (\"%s\", %s)" s (Z.to_string n) region, sprintf "Mutez (%S, %s)" s (Z.to_string n)
| Ident Region.{region; value} -> | Ident Region.{region; value} ->
region, sprintf "Ident %s" value region, sprintf "Ident %S" value
| Constr Region.{region; value} -> | Constr Region.{region; value} ->
region, sprintf "Constr %s" value region, sprintf "Constr %S" value
| Attr Region.{region; value} -> | Attr Region.{region; value} ->
region, sprintf "Attr \"%s\"" value region, sprintf "Attr %S" value
| Lang Region.{region; value} ->
region, sprintf "Lang %S" (value.Region.value)
(* Symbols *) (* Symbols *)
| ARROW region -> region, "ARROW" | ARROW region -> region, "ARROW"
| CONS region -> region, "CONS" | CONS region -> region, "CONS"
@ -141,7 +143,6 @@ let proj_token = function
| PLUS region -> region, "PLUS" | PLUS region -> region, "PLUS"
| SLASH region -> region, "SLASH" | SLASH region -> region, "SLASH"
| TIMES region -> region, "TIMES" | TIMES region -> region, "TIMES"
| PERCENT region -> region, "PERCENT"
| LPAR region -> region, "LPAR" | LPAR region -> region, "LPAR"
| RPAR region -> region, "RPAR" | RPAR region -> region, "RPAR"
| LBRACKET region -> region, "LBRACKET" | LBRACKET region -> region, "LBRACKET"
@ -206,6 +207,7 @@ let to_lexeme = function
| Ident id -> id.Region.value | Ident id -> id.Region.value
| Constr id -> id.Region.value | Constr id -> id.Region.value
| Attr a -> a.Region.value | Attr a -> a.Region.value
| Lang lang -> Region.(lang.value.value)
(* Symbols *) (* Symbols *)
@ -216,7 +218,6 @@ let to_lexeme = function
| PLUS _ -> "+" | PLUS _ -> "+"
| SLASH _ -> "/" | SLASH _ -> "/"
| TIMES _ -> "*" | TIMES _ -> "*"
| PERCENT _ -> "%"
| LPAR _ -> "(" | LPAR _ -> "("
| RPAR _ -> ")" | RPAR _ -> ")"
| LBRACKET _ -> "[" | LBRACKET _ -> "["
@ -478,7 +479,6 @@ let mk_sym lexeme region =
| "-" -> Ok (MINUS region) | "-" -> Ok (MINUS region)
| "*" -> Ok (TIMES region) | "*" -> Ok (TIMES region)
| "/" -> Ok (SLASH region) | "/" -> Ok (SLASH region)
| "%" -> Ok (PERCENT region)
| "<" -> Ok (LT region) | "<" -> Ok (LT region)
| "<=" -> Ok (LE region) | "<=" -> Ok (LE region)
| ">" -> Ok (GT region) | ">" -> Ok (GT region)
@ -512,6 +512,10 @@ let mk_attr header lexeme region =
if header = "[@" then Error Invalid_attribute if header = "[@" then Error Invalid_attribute
else Ok (Attr Region.{value=lexeme; region}) else Ok (Attr Region.{value=lexeme; region})
(* Language injection *)
let mk_lang lang region = Lang Region.{value=lang; region}
(* Predicates *) (* Predicates *)
let is_string = function String _ -> true | _ -> false let is_string = function String _ -> true | _ -> false
@ -573,7 +577,7 @@ let check_right_context token next_token buffer : unit =
else () else ()
else else
if is_bytes token if is_bytes token
then if is_string next || is_ident next then if is_string next || is_ident next
then fail region Missing_break then fail region Missing_break
else if is_int next else if is_int next
then fail region Odd_lengthed_bytes then fail region Odd_lengthed_bytes

20
src/passes/01-parser/cameligo/ParToken.mly
View File

@ -5,15 +5,16 @@
(* Literals *) (* Literals *)
%token <string Region.reg> String "<string>" %token <string Region.reg> String "<string>"
%token <string Region.reg> Verbatim "<verbatim>" %token <string Region.reg> Verbatim "<verbatim>"
%token <(LexToken.lexeme * Hex.t) Region.reg> Bytes "<bytes>" %token <(LexToken.lexeme * Hex.t) Region.reg> Bytes "<bytes>"
%token <(string * Z.t) Region.reg> Int "<int>" %token <(string * Z.t) Region.reg> Int "<int>"
%token <(string * Z.t) Region.reg> Nat "<nat>" %token <(string * Z.t) Region.reg> Nat "<nat>"
%token <(string * Z.t) Region.reg> Mutez "<mutez>" %token <(string * Z.t) Region.reg> Mutez "<mutez>"
%token <string Region.reg> Ident "<ident>" %token <string Region.reg> Ident "<ident>"
%token <string Region.reg> Constr "<constr>" %token <string Region.reg> Constr "<constr>"
%token <string Region.reg> Attr "<attr>" %token <string Region.reg> Attr "<attr>"
%token <LexToken.lexeme Region.reg Region.reg> Lang "<lang>"
(* Symbols *) (* Symbols *)
@ -21,7 +22,6 @@
%token <Region.t> PLUS "+" %token <Region.t> PLUS "+"
%token <Region.t> SLASH "/" %token <Region.t> SLASH "/"
%token <Region.t> TIMES "*" %token <Region.t> TIMES "*"
%token <Region.t> PERCENT "%"
%token <Region.t> LPAR "(" %token <Region.t> LPAR "("
%token <Region.t> RPAR ")" %token <Region.t> RPAR ")"

24
src/passes/01-parser/cameligo/Parser.mly
View File

@ -121,11 +121,10 @@ type_decl:
"type" type_name "=" type_expr { "type" type_name "=" type_expr {
Scoping.check_reserved_name $2; Scoping.check_reserved_name $2;
let region = cover $1 (type_expr_to_region $4) in let region = cover $1 (type_expr_to_region $4) in
let value = { let value = {kwd_type = $1;
kwd_type = $1; name = $2;
name = $2; eq = $3;
eq = $3; type_expr = $4}
type_expr = $4}
in {region; value} } in {region; value} }
type_expr: type_expr:
@ -583,7 +582,7 @@ core_expr:
| sequence { ESeq $1 } | sequence { ESeq $1 }
| record_expr { ERecord $1 } | record_expr { ERecord $1 }
| update_record { EUpdate $1 } | update_record { EUpdate $1 }
| code_insert { ECodeInsert $1 } | code_inj { ECodeInj $1 }
| par(expr) { EPar $1 } | par(expr) { EPar $1 }
| par(annot_expr) { EAnnot $1 } | par(annot_expr) { EAnnot $1 }
@ -708,13 +707,8 @@ last_expr:
seq_expr: seq_expr:
disj_expr_level | if_then_else (seq_expr) { $1 } disj_expr_level | if_then_else (seq_expr) { $1 }
code_insert: code_inj:
"[" "%" Constr expr "]" { "<lang>" expr "]" {
let region = cover $1 $5 in let region = cover $1.region $3
let value = { and value = {language=$1; code=$2; rbracket=$3}
lbracket =$1;
percent =$2;
language =$3;
code =$4;
rbracket =$5}
in {region; value} } in {region; value} }

48
src/passes/01-parser/cameligo/ParserLog.ml
View File

@ -89,12 +89,6 @@ let print_pvar state {region; value} =
(compact state region) value (compact state region) value
in Buffer.add_string state#buffer line in Buffer.add_string state#buffer line
let print_uident state {region; value} =
let line =
sprintf "%s: Uident %s\n"
(compact state region) value
in Buffer.add_string state#buffer line
let print_string state {region; value} = let print_string state {region; value} =
let line = let line =
sprintf "%s: String %S\n" sprintf "%s: String %S\n"
@ -103,7 +97,7 @@ let print_string state {region; value} =
let print_verbatim state {region; value} = let print_verbatim state {region; value} =
let line = let line =
sprintf "%s: Verbatim {|%s|}\n" sprintf "%s: Verbatim %S\n"
(compact state region) value (compact state region) value
in Buffer.add_string state#buffer line in Buffer.add_string state#buffer line
@ -211,7 +205,7 @@ and print_cartesian state Region.{value;_} =
print_nsepseq state "*" print_type_expr value print_nsepseq state "*" print_type_expr value
and print_variant state {value = {constr; arg}; _} = and print_variant state {value = {constr; arg}; _} =
print_uident state constr; print_constr state constr;
match arg with match arg with
None -> () None -> ()
| Some (kwd_of, t_expr) -> | Some (kwd_of, t_expr) ->
@ -340,7 +334,7 @@ and print_some_app_pattern state {value; _} =
and print_constr_app_pattern state node = and print_constr_app_pattern state node =
let {value=constr, p_opt; _} = node in let {value=constr, p_opt; _} = node in
print_uident state constr; print_constr state constr;
match p_opt with match p_opt with
None -> () None -> ()
| Some pattern -> print_pattern state pattern | Some pattern -> print_pattern state pattern
@ -366,7 +360,7 @@ and print_expr state = function
| ESeq seq -> print_sequence state seq | ESeq seq -> print_sequence state seq
| ERecord e -> print_record_expr state e | ERecord e -> print_record_expr state e
| EConstr e -> print_constr_expr state e | EConstr e -> print_constr_expr state e
| ECodeInsert e -> print_code_insert state e | ECodeInj e -> print_code_inj state e
and print_constr_expr state = function and print_constr_expr state = function
ENone e -> print_none_expr state e ENone e -> print_none_expr state e
@ -519,13 +513,15 @@ and print_comp_expr state = function
and print_record_expr state e = and print_record_expr state e =
print_ne_injection state print_field_assign e print_ne_injection state print_field_assign e
and print_code_insert state {value; _} = and print_code_inj state {value; _} =
let {lbracket;percent;language;code;rbracket} : code_insert = value in let {language; code; rbracket} = value in
print_token state lbracket "["; let {value=lang; region} = language in
print_token state percent "%"; let header_stop = region#start#shift_bytes 1 in
print_string state language; let header_reg = Region.make ~start:region#start ~stop:header_stop in
print_expr state code; print_token state header_reg "[%";
print_token state rbracket "]" print_string state lang;
print_expr state code;
print_token state rbracket "]"
and print_field_assign state {value; _} = and print_field_assign state {value; _} =
let {field_name; assignment; field_expr} = value in let {field_name; assignment; field_expr} = value in
@ -871,9 +867,9 @@ and pp_expr state = function
| ESeq {value; region} -> | ESeq {value; region} ->
pp_loc_node state "ESeq" region; pp_loc_node state "ESeq" region;
pp_injection pp_expr state value pp_injection pp_expr state value
| ECodeInsert {value; region} -> | ECodeInj {value; region} ->
pp_loc_node state "ECodeInsert" region; pp_loc_node state "ECodeInj" region;
pp_code_insert state value pp_code_inj state value
and pp_fun_expr state node = and pp_fun_expr state node =
let {binders; lhs_type; body; _} = node in let {binders; lhs_type; body; _} = node in
@ -895,16 +891,16 @@ and pp_fun_expr state node =
pp_expr (state#pad 1 0) body pp_expr (state#pad 1 0) body
in () in ()
and pp_code_insert state (rc : code_insert) = and pp_code_inj state rc =
let () = let () =
let state = state#pad 3 0 in let state = state#pad 2 0 in
pp_node state "<language>"; pp_node state "<language>";
pp_string (state#pad 1 0) rc.language in pp_string (state#pad 1 0) rc.language.value in
let () = let () =
let state = state#pad 3 1 in let state = state#pad 2 1 in
pp_node state "<code>"; pp_node state "<code>";
pp_expr (state#pad 1 0) rc.code in pp_expr (state#pad 1 0) rc.code
() in ()
and pp_let_in state node = and pp_let_in state node =
let {binding; body; attributes; kwd_rec; _} = node in let {binding; body; attributes; kwd_rec; _} = node in

40
src/passes/01-parser/cameligo/Pretty.ml
View File

@ -52,22 +52,22 @@ and pp_let_binding (binding : let_binding) =
in prefix 2 1 (lhs ^^ string " =") (pp_expr let_rhs) in prefix 2 1 (lhs ^^ string " =") (pp_expr let_rhs)
and pp_pattern = function and pp_pattern = function
PConstr p -> pp_pconstr p PConstr p -> pp_pconstr p
| PUnit _ -> string "()" | PUnit _ -> string "()"
| PFalse _ -> string "false" | PFalse _ -> string "false"
| PTrue _ -> string "true" | PTrue _ -> string "true"
| PVar v -> pp_ident v | PVar v -> pp_ident v
| PInt i -> pp_int i | PInt i -> pp_int i
| PNat n -> pp_nat n | PNat n -> pp_nat n
| PBytes b -> pp_bytes b | PBytes b -> pp_bytes b
| PString s -> pp_string s | PString s -> pp_string s
| PVerbatim s -> pp_verbatim s | PVerbatim s -> pp_verbatim s
| PWild _ -> string "_" | PWild _ -> string "_"
| PList l -> pp_plist l | PList l -> pp_plist l
| PTuple t -> pp_ptuple t | PTuple t -> pp_ptuple t
| PPar p -> pp_ppar p | PPar p -> pp_ppar p
| PRecord r -> pp_precord r | PRecord r -> pp_precord r
| PTyped t -> pp_ptyped t | PTyped t -> pp_ptyped t
and pp_pconstr = function and pp_pconstr = function
PNone _ -> string "None" PNone _ -> string "None"
@ -152,7 +152,7 @@ and pp_expr = function
| ELetIn e -> pp_let_in e | ELetIn e -> pp_let_in e
| EFun e -> pp_fun e | EFun e -> pp_fun e
| ESeq e -> pp_seq e | ESeq e -> pp_seq e
| ECodeInsert e -> pp_code_insert e | ECodeInj e -> pp_code_inj e
and pp_case_expr {value; _} = and pp_case_expr {value; _} =
let {expr; cases; _} = value in let {expr; cases; _} = value in
@ -314,11 +314,11 @@ and pp_update {value; _} =
string "{" ^^ record ^^ string " with" string "{" ^^ record ^^ string " with"
^^ nest 2 (break 1 ^^ updates ^^ string "}") ^^ nest 2 (break 1 ^^ updates ^^ string "}")
and pp_code_insert {value; _} = and pp_code_inj {value; _} =
let {language; code; _} = value in let {language; code; _} = value in
let language = pp_string language let language = pp_string language.value
and code = pp_expr code in and code = pp_expr code in
string "[%" ^^ language ^^ string " " ^^ code ^^ string " ]" string "[%" ^^ language ^/^ code ^^ string "]"
and pp_field_path_assign {value; _} = and pp_field_path_assign {value; _} =
let {field_path; field_expr; _} = value in let {field_path; field_expr; _} = value in

1921
src/passes/01-parser/cameligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

79
src/passes/01-parser/pascaligo/AST.ml
View File

@ -82,7 +82,6 @@ type rbrace = Region.t (* "}" *)
type lbracket = Region.t (* "[" *) type lbracket = Region.t (* "[" *)
type rbracket = Region.t (* "]" *) type rbracket = Region.t (* "]" *)
type cons = Region.t (* "#" *) type cons = Region.t (* "#" *)
type percent = Region.t (* "%" *)
type vbar = Region.t (* "|" *) type vbar = Region.t (* "|" *)
type arrow = Region.t (* "->" *) type arrow = Region.t (* "->" *)
type assign = Region.t (* ":=" *) type assign = Region.t (* ":=" *)
@ -427,12 +426,14 @@ and for_collect = {
block : block reg block : block reg
} }
and code_insert = { (* Code injection. Note how the field [language] wraps a region in
lbracket : lbracket; another: the outermost region covers the header "[%<language>" and
percent : percent; the innermost covers the <language>. *)
language : string reg;
code : expr; and code_inj = {
rbracket : rbracket; language : string reg reg;
code : expr;
rbracket : rbracket;
} }
and collection = and collection =
@ -443,27 +444,27 @@ and collection =
(* Expressions *) (* Expressions *)
and expr = and expr =
ECase of expr case reg ECase of expr case reg
| ECond of cond_expr reg | ECond of cond_expr reg
| EAnnot of annot_expr par reg | EAnnot of annot_expr par reg
| ELogic of logic_expr | ELogic of logic_expr
| EArith of arith_expr | EArith of arith_expr
| EString of string_expr | EString of string_expr
| EList of list_expr | EList of list_expr
| ESet of set_expr | ESet of set_expr
| EConstr of constr_expr | EConstr of constr_expr
| ERecord of record reg | ERecord of record reg
| EProj of projection reg | EProj of projection reg
| EUpdate of update reg | EUpdate of update reg
| EMap of map_expr | EMap of map_expr
| EVar of Lexer.lexeme reg | EVar of Lexer.lexeme reg
| ECall of fun_call | ECall of fun_call
| EBytes of (Lexer.lexeme * Hex.t) reg | EBytes of (Lexer.lexeme * Hex.t) reg
| EUnit of c_Unit | EUnit of c_Unit
| ETuple of tuple_expr | ETuple of tuple_expr
| EPar of expr par reg | EPar of expr par reg
| EFun of fun_expr reg | EFun of fun_expr reg
| ECodeInsert of code_insert reg | ECodeInj of code_inj reg
and annot_expr = expr * colon * type_expr and annot_expr = expr * colon * type_expr
@ -680,17 +681,17 @@ let rec expr_to_region = function
| ERecord e -> record_expr_to_region e | ERecord e -> record_expr_to_region e
| EMap e -> map_expr_to_region e | EMap e -> map_expr_to_region e
| ETuple e -> tuple_expr_to_region e | ETuple e -> tuple_expr_to_region e
| EUpdate {region; _} | EUpdate {region; _}
| EProj {region; _} | EProj {region; _}
| EVar {region; _} | EVar {region; _}
| ECall {region; _} | ECall {region; _}
| EBytes {region; _} | EBytes {region; _}
| EUnit region | EUnit region
| ECase {region;_} | ECase {region;_}
| ECond {region; _} | ECond {region; _}
| EPar {region; _} | EPar {region; _}
| EFun {region; _} | EFun {region; _}
| ECodeInsert {region; _} -> region | ECodeInj {region; _} -> region
and tuple_expr_to_region {region; _} = region and tuple_expr_to_region {region; _} = region

3
src/passes/01-parser/pascaligo/LexToken.mli
View File

@ -44,6 +44,7 @@ type t =
| Mutez of (lexeme * Z.t) Region.reg | Mutez of (lexeme * Z.t) Region.reg
| Ident of lexeme Region.reg | Ident of lexeme Region.reg
| Constr of lexeme Region.reg | Constr of lexeme Region.reg
| Lang of lexeme Region.reg Region.reg
(* Symbols *) (* Symbols *)
@ -73,7 +74,6 @@ type t =
| DOT of Region.t (* "." *) | DOT of Region.t (* "." *)
| WILD of Region.t (* "_" *) | WILD of Region.t (* "_" *)
| CAT of Region.t (* "^" *) | CAT of Region.t (* "^" *)
| PERCENT of Region.t (* "%" *)
(* Keywords *) (* Keywords *)
@ -162,6 +162,7 @@ val mk_verbatim : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token
val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result
val mk_lang : lexeme Region.reg -> Region.t -> token
val eof : Region.t -> token val eof : Region.t -> token
(* Predicates *) (* Predicates *)

41
src/passes/01-parser/pascaligo/LexToken.mll
View File

@ -32,6 +32,7 @@ type t =
| Mutez of (lexeme * Z.t) Region.reg | Mutez of (lexeme * Z.t) Region.reg
| Ident of lexeme Region.reg | Ident of lexeme Region.reg
| Constr of lexeme Region.reg | Constr of lexeme Region.reg
| Lang of lexeme Region.reg Region.reg
(* Symbols *) (* Symbols *)
@ -61,7 +62,6 @@ type t =
| DOT of Region.t | DOT of Region.t
| WILD of Region.t | WILD of Region.t
| CAT of Region.t | CAT of Region.t
| PERCENT of Region.t (* "%" *)
(* Keywords *) (* Keywords *)
@ -126,26 +126,23 @@ let proj_token = function
region, sprintf "String %S" value region, sprintf "String %S" value
| Verbatim Region.{region; value} -> | Verbatim Region.{region; value} ->
region, sprintf "Verbatim {|%s|}" value region, sprintf "Verbatim %S" value
| Bytes Region.{region; value = s,b} -> | Bytes Region.{region; value = s,b} ->
region, region,
sprintf "Bytes (\"%s\", \"0x%s\")" s (Hex.show b) sprintf "Bytes (%S, \"0x%s\")" s (Hex.show b)
| Int Region.{region; value = s,n} -> | Int Region.{region; value = s,n} ->
region, sprintf "Int (\"%s\", %s)" s (Z.to_string n) region, sprintf "Int (%S, %s)" s (Z.to_string n)
| Nat Region.{region; value = s,n} -> | Nat Region.{region; value = s,n} ->
region, sprintf "Nat (\"%s\", %s)" s (Z.to_string n) region, sprintf "Nat (%S, %s)" s (Z.to_string n)
| Mutez Region.{region; value = s,n} -> | Mutez Region.{region; value = s,n} ->
region, sprintf "Mutez (\"%s\", %s)" s (Z.to_string n) region, sprintf "Mutez (%S, %s)" s (Z.to_string n)
| Ident Region.{region; value} -> | Ident Region.{region; value} ->
region, sprintf "Ident \"%s\"" value region, sprintf "Ident %S" value
| Constr Region.{region; value} -> | Constr Region.{region; value} ->
region, sprintf "Constr \"%s\"" value region, sprintf "Constr %S" value
| Lang Region.{region; value} ->
(* region, sprintf "Lang %S" (value.Region.value)
| Attr {header; string={region; value}} ->
region, sprintf "Attr (\"%s\",\"%s\")" header value
*)
(* Symbols *) (* Symbols *)
@ -175,7 +172,6 @@ let proj_token = function
| DOT region -> region, "DOT" | DOT region -> region, "DOT"
| WILD region -> region, "WILD" | WILD region -> region, "WILD"
| CAT region -> region, "CAT" | CAT region -> region, "CAT"
| PERCENT region -> region, "PERCENT"
(* Keywords *) (* Keywords *)
@ -232,14 +228,15 @@ let proj_token = function
let to_lexeme = function let to_lexeme = function
(* Literals *) (* Literals *)
String s -> String.escaped s.Region.value String s -> String.escaped s.Region.value
| Verbatim v -> String.escaped v.Region.value | Verbatim v -> String.escaped v.Region.value
| Bytes b -> fst b.Region.value | Bytes b -> fst b.Region.value
| Int i | Int i
| Nat i | Nat i
| Mutez i -> fst i.Region.value | Mutez i -> fst i.Region.value
| Ident id | Ident id
| Constr id -> id.Region.value | Constr id -> id.Region.value
| Lang lang -> Region.(lang.value.value)
(* Symbols *) (* Symbols *)
@ -269,7 +266,6 @@ let to_lexeme = function
| DOT _ -> "." | DOT _ -> "."
| WILD _ -> "_" | WILD _ -> "_"
| CAT _ -> "^" | CAT _ -> "^"
| PERCENT _ -> "%"
(* Keywords *) (* Keywords *)
@ -521,7 +517,6 @@ let mk_sym lexeme region =
| "-" -> Ok (MINUS region) | "-" -> Ok (MINUS region)
| "*" -> Ok (TIMES region) | "*" -> Ok (TIMES region)
| "/" -> Ok (SLASH region) | "/" -> Ok (SLASH region)
| "%" -> Ok (PERCENT region)
| "<" -> Ok (LT region) | "<" -> Ok (LT region)
| "<=" -> Ok (LE region) | "<=" -> Ok (LE region)
| ">" -> Ok (GT region) | ">" -> Ok (GT region)
@ -552,6 +547,10 @@ type attr_err = Invalid_attribute
let mk_attr _ _ _ = Error Invalid_attribute let mk_attr _ _ _ = Error Invalid_attribute
(* Language injection *)
let mk_lang lang region = Lang Region.{value=lang; region}
(* Predicates *) (* Predicates *)
let is_string = function String _ -> true | _ -> false let is_string = function String _ -> true | _ -> false
@ -613,7 +612,7 @@ let check_right_context token next_token buffer : unit =
else () else ()
else else
if is_bytes token if is_bytes token
then if is_string next || is_ident next then if is_string next || is_ident next
then fail region Missing_break then fail region Missing_break
else if is_int next else if is_int next
then fail region Odd_lengthed_bytes then fail region Odd_lengthed_bytes

18
src/passes/01-parser/pascaligo/ParToken.mly
View File

@ -5,14 +5,15 @@
(* Literals *) (* Literals *)
%token <LexToken.lexeme Region.reg> String "<string>" %token <LexToken.lexeme Region.reg> String "<string>"
%token <LexToken.lexeme Region.reg> Verbatim "<verbatim>" %token <LexToken.lexeme Region.reg> Verbatim "<verbatim>"
%token <(LexToken.lexeme * Hex.t) Region.reg> Bytes "<bytes>" %token <(LexToken.lexeme * Hex.t) Region.reg> Bytes "<bytes>"
%token <(LexToken.lexeme * Z.t) Region.reg> Int "<int>" %token <(LexToken.lexeme * Z.t) Region.reg> Int "<int>"
%token <(LexToken.lexeme * Z.t) Region.reg> Nat "<nat>" %token <(LexToken.lexeme * Z.t) Region.reg> Nat "<nat>"
%token <(LexToken.lexeme * Z.t) Region.reg> Mutez "<mutez>" %token <(LexToken.lexeme * Z.t) Region.reg> Mutez "<mutez>"
%token <LexToken.lexeme Region.reg> Ident "<ident>" %token <LexToken.lexeme Region.reg> Ident "<ident>"
%token <LexToken.lexeme Region.reg> Constr "<constr>" %token <LexToken.lexeme Region.reg> Constr "<constr>"
%token <LexToken.lexeme Region.reg Region.reg> Lang "<lang>"
(* Symbols *) (* Symbols *)
@ -42,7 +43,6 @@
%token <Region.t> DOT "." %token <Region.t> DOT "."
%token <Region.t> WILD "_" %token <Region.t> WILD "_"
%token <Region.t> CAT "^" %token <Region.t> CAT "^"
%token <Region.t> PERCENT "%"
(* Keywords *) (* Keywords *)

15
src/passes/01-parser/pascaligo/Parser.mly
View File

@ -846,7 +846,7 @@ core_expr:
| set_expr { ESet $1 } | set_expr { ESet $1 }
| record_expr { ERecord $1 } | record_expr { ERecord $1 }
| update_record { EUpdate $1 } | update_record { EUpdate $1 }
| code_insert_expr { ECodeInsert $1 } | code_inj { ECodeInj $1 }
| "<constr>" arguments { | "<constr>" arguments {
let region = cover $1.region $2.region in let region = cover $1.region $2.region in
EConstr (ConstrApp {region; value = $1, Some $2}) EConstr (ConstrApp {region; value = $1, Some $2})
@ -965,15 +965,10 @@ update_record:
let value = {record=$1; kwd_with=$2; updates} let value = {record=$1; kwd_with=$2; updates}
in {region; value} } in {region; value} }
code_insert_expr: code_inj:
"[" "%" Constr expr "]" { "<lang>" expr "]" {
let region = cover $1 $5 in let region = cover $1.region $3
let value = { and value = {language=$1; code=$2; rbracket=$3}
lbracket =$1;
percent =$2;
language =$3;
code =$4;
rbracket =$5}
in {region; value} } in {region; value} }
field_assignment: field_assignment:

56
src/passes/01-parser/pascaligo/ParserLog.ml
View File

@ -76,26 +76,32 @@ let print_token state region lexeme =
let print_var state {region; value} = let print_var state {region; value} =
let line = let line =
sprintf "%s: Ident \"%s\"\n" sprintf "%s: Ident %S\n"
(compact state region) value (compact state region) value
in Buffer.add_string state#buffer line in Buffer.add_string state#buffer line
let print_constr state {region; value} = let print_constr state {region; value} =
let line = let line =
sprintf "%s: Constr \"%s\"\n" sprintf "%s: Constr %S\n"
(compact state region) value (compact state region) value
in Buffer.add_string state#buffer line in Buffer.add_string state#buffer line
let print_string state {region; value} = let print_string state {region; value} =
let line = let line =
sprintf "%s: String %s\n" sprintf "%s: String %S\n"
(compact state region) value
in Buffer.add_string state#buffer line
let print_verbatim state {region; value} =
let line =
sprintf "%s: Verbatim %S\n"
(compact state region) value (compact state region) value
in Buffer.add_string state#buffer line in Buffer.add_string state#buffer line
let print_bytes state {region; value} = let print_bytes state {region; value} =
let lexeme, abstract = value in let lexeme, abstract = value in
let line = let line =
sprintf "%s: Bytes (\"%s\", \"0x%s\")\n" sprintf "%s: Bytes (%S, \"0x%s\")\n"
(compact state region) lexeme (compact state region) lexeme
(Hex.show abstract) (Hex.show abstract)
in Buffer.add_string state#buffer line in Buffer.add_string state#buffer line
@ -103,7 +109,7 @@ let print_bytes state {region; value} =
let print_int state {region; value} = let print_int state {region; value} =
let lexeme, abstract = value in let lexeme, abstract = value in
let line = let line =
sprintf "%s: Int (\"%s\", %s)\n" sprintf "%s: Int (%S, %s)\n"
(compact state region) lexeme (compact state region) lexeme
(Z.to_string abstract) (Z.to_string abstract)
in Buffer.add_string state#buffer line in Buffer.add_string state#buffer line
@ -111,7 +117,7 @@ let print_int state {region; value} =
let print_nat state {region; value} = let print_nat state {region; value} =
let lexeme, abstract = value in let lexeme, abstract = value in
let line = let line =
sprintf "%s: Nat (\"%s\", %s)\n" sprintf "%s: Nat (%S, %s)\n"
(compact state region) lexeme (compact state region) lexeme
(Z.to_string abstract) (Z.to_string abstract)
in Buffer.add_string state#buffer line in Buffer.add_string state#buffer line
@ -236,13 +242,15 @@ and print_fun_expr state {value; _} =
print_token state kwd_is "is"; print_token state kwd_is "is";
print_expr state return print_expr state return
and print_code_insert state {value; _} = and print_code_inj state {value; _} =
let {lbracket;percent;language;code;rbracket} : code_insert = value in let {language; code; rbracket} = value in
print_token state lbracket "["; let {value=lang; region} = language in
print_token state percent "%"; let header_stop = region#start#shift_bytes 1 in
print_string state language; let header_reg = Region.make ~start:region#start ~stop:header_stop in
print_expr state code; print_token state header_reg "[%";
print_token state rbracket "]" print_string state lang;
print_expr state code;
print_token state rbracket "]"
and print_parameters state {value; _} = and print_parameters state {value; _} =
let {lpar; inside; rpar} = value in let {lpar; inside; rpar} = value in
@ -466,7 +474,7 @@ and print_expr state = function
| ETuple e -> print_tuple_expr state e | ETuple e -> print_tuple_expr state e
| EPar e -> print_par_expr state e | EPar e -> print_par_expr state e
| EFun e -> print_fun_expr state e | EFun e -> print_fun_expr state e
| ECodeInsert e -> print_code_insert state e | ECodeInj e -> print_code_inj state e
and print_annot_expr state node = and print_annot_expr state node =
let {inside; _} : annot_expr par = node in let {inside; _} : annot_expr par = node in
@ -608,7 +616,7 @@ and print_string_expr state = function
| String s -> | String s ->
print_string state s print_string state s
| Verbatim v -> | Verbatim v ->
print_string state v print_verbatim state v
and print_list_expr state = function and print_list_expr state = function
ECons {value = {arg1; op; arg2}; _} -> ECons {value = {arg1; op; arg2}; _} ->
@ -1020,16 +1028,16 @@ and pp_fun_expr state (expr: fun_expr) =
pp_expr (state#pad 1 0) expr.return pp_expr (state#pad 1 0) expr.return
in () in ()
and pp_code_insert state (rc : code_insert) = and pp_code_inj state rc =
let () = let () =
let state = state#pad 3 0 in let state = state#pad 2 0 in
pp_node state "<language>"; pp_node state "<language>";
pp_string (state#pad 1 0) rc.language in pp_string (state#pad 1 0) rc.language.value in
let () = let () =
let state = state#pad 3 1 in let state = state#pad 2 1 in
pp_node state "<code>"; pp_node state "<code>";
pp_expr (state#pad 1 0) rc.code in pp_expr (state#pad 1 0) rc.code
() in ()
and pp_parameters state {value; _} = and pp_parameters state {value; _} =
let params = Utils.nsepseq_to_list value.inside in let params = Utils.nsepseq_to_list value.inside in
@ -1510,9 +1518,9 @@ and pp_expr state = function
| EFun {value; region} -> | EFun {value; region} ->
pp_loc_node state "EFun" region; pp_loc_node state "EFun" region;
pp_fun_expr state value; pp_fun_expr state value;
| ECodeInsert {value; region} -> | ECodeInj {value; region} ->
pp_loc_node state "ECodeInsert" region; pp_loc_node state "ECodeInj" region;
pp_code_insert state value; pp_code_inj state value;
and pp_list_expr state = function and pp_list_expr state = function
ECons {value; region} -> ECons {value; region} ->

10
src/passes/01-parser/pascaligo/Pretty.ml
View File

@ -377,7 +377,7 @@ and pp_expr = function
| ETuple e -> pp_tuple_expr e | ETuple e -> pp_tuple_expr e
| EPar e -> pp_par pp_expr e | EPar e -> pp_par pp_expr e
| EFun e -> pp_fun_expr e | EFun e -> pp_fun_expr e
| ECodeInsert e -> pp_code_insert e | ECodeInj e -> pp_code_inj e
and pp_annot_expr {value; _} = and pp_annot_expr {value; _} =
let expr, _, type_expr = value.inside in let expr, _, type_expr = value.inside in
@ -492,11 +492,11 @@ and pp_update {value; _} =
and record = pp_path record in and record = pp_path record in
record ^^ string " with" ^^ nest 2 (break 1 ^^ updates) record ^^ string " with" ^^ nest 2 (break 1 ^^ updates)
and pp_code_insert {value; _} = and pp_code_inj {value; _} =
let {language; code; _} = value in let {language; code; _} = value in
let language = pp_string language let language = pp_string language.value
and code = pp_expr code in and code = pp_expr code in
string "[%" ^^ language ^^ string " " ^^ code ^^ string " ]" string "[%" ^^ language ^/^ code ^^ string "]"
and pp_field_path_assign {value; _} = and pp_field_path_assign {value; _} =
let {field_path; field_expr; _} = value in let {field_path; field_expr; _} = value in

1750
src/passes/01-parser/pascaligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

31
src/passes/01-parser/reasonligo/LexToken.mli
View File

@ -29,9 +29,22 @@ type lexeme = string
(* TOKENS *) (* TOKENS *)
type t = type t =
(* Identifiers, labels, numbers and strings *)
| Ident of string Region.reg
| Constr of string Region.reg
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Verbatim of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
| Lang of lexeme Region.reg Region.reg
(* Symbols *) (* Symbols *)
CAT of Region.t (* "++" *) | CAT of Region.t (* "++" *)
(* Arithmetics *) (* Arithmetics *)
@ -39,7 +52,6 @@ type t =
| PLUS of Region.t (* "+" *) | PLUS of Region.t (* "+" *)
| SLASH of Region.t (* "/" *) | SLASH of Region.t (* "/" *)
| TIMES of Region.t (* "*" *) | TIMES of Region.t (* "*" *)
| PERCENT of Region.t (* "%" *)
(* Compounds *) (* Compounds *)
@ -80,18 +92,6 @@ type t =
| BOOL_AND of Region.t (* "&&" *) | BOOL_AND of Region.t (* "&&" *)
| NOT of Region.t (* ! *) | NOT of Region.t (* ! *)
(* Identifiers, labels, numbers and strings *)
| Ident of string Region.reg
| Constr of string Region.reg
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Verbatim of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
(* Keywords *) (* Keywords *)
| Else of Region.t | Else of Region.t
@ -147,13 +147,14 @@ val mk_int : lexeme -> Region.t -> (token, int_err) result
val mk_nat : lexeme -> Region.t -> (token, nat_err) result val mk_nat : lexeme -> Region.t -> (token, nat_err) result
val mk_mutez : lexeme -> Region.t -> (token, int_err) result val mk_mutez : lexeme -> Region.t -> (token, int_err) result
val mk_ident : lexeme -> Region.t -> (token, ident_err) result val mk_ident : lexeme -> Region.t -> (token, ident_err) result
val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result
val mk_sym : lexeme -> Region.t -> (token, sym_err) result val mk_sym : lexeme -> Region.t -> (token, sym_err) result
val mk_kwd : lexeme -> Region.t -> (token, kwd_err) result val mk_kwd : lexeme -> Region.t -> (token, kwd_err) result
val mk_string : lexeme -> Region.t -> token val mk_string : lexeme -> Region.t -> token
val mk_verbatim : lexeme -> Region.t -> token val mk_verbatim : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token
val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result
val mk_lang : lexeme Region.reg -> Region.t -> token
val eof : Region.t -> token val eof : Region.t -> token
(* Predicates *) (* Predicates *)

59
src/passes/01-parser/reasonligo/LexToken.mll
View File

@ -15,9 +15,22 @@ let sprintf = Printf.sprintf
(* TOKENS *) (* TOKENS *)
type t = type t =
(* Identifiers, labels, numbers and strings *)
| Ident of string Region.reg
| Constr of string Region.reg
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Verbatim of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
| Lang of lexeme Region.reg Region.reg
(* Symbols *) (* Symbols *)
CAT of Region.t (* "++" *) | CAT of Region.t (* "++" *)
(* Arithmetics *) (* Arithmetics *)
@ -25,7 +38,6 @@ type t =
| PLUS of Region.t (* "+" *) | PLUS of Region.t (* "+" *)
| SLASH of Region.t (* "/" *) | SLASH of Region.t (* "/" *)
| TIMES of Region.t (* "*" *) | TIMES of Region.t (* "*" *)
| PERCENT of Region.t (* "%" *)
(* Compounds *) (* Compounds *)
@ -66,18 +78,6 @@ type t =
| BOOL_AND of Region.t (* "&&" *) | BOOL_AND of Region.t (* "&&" *)
| NOT of Region.t (* ! *) | NOT of Region.t (* ! *)
(* Identifiers, labels, numbers and strings *)
| Ident of string Region.reg
| Constr of string Region.reg
| Int of (string * Z.t) Region.reg
| Nat of (string * Z.t) Region.reg
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Verbatim of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
(* Keywords *) (* Keywords *)
| Else of Region.t | Else of Region.t
@ -109,22 +109,26 @@ let proj_token = function
(* Literals *) (* Literals *)
String Region.{region; value} -> String Region.{region; value} ->
region, sprintf "String %s" value region, sprintf "String %S" value
| Verbatim Region.{region; value} -> | Verbatim Region.{region; value} ->
region, sprintf "Verbatim {|%s|}" value region, sprintf "Verbatim %S" value
| Bytes Region.{region; value = s,b} -> | Bytes Region.{region; value = s,b} ->
region, region,
sprintf "Bytes (\"%s\", \"0x%s\")" s (Hex.show b) sprintf "Bytes (%S, \"0x%s\")" s (Hex.show b)
| Int Region.{region; value = s,n} -> | Int Region.{region; value = s,n} ->
region, sprintf "Int (\"%s\", %s)" s (Z.to_string n) region, sprintf "Int (%S, %s)" s (Z.to_string n)
| Nat Region.{region; value = s,n} -> | Nat Region.{region; value = s,n} ->
region, sprintf "Nat (\"%s\", %s)" s (Z.to_string n) region, sprintf "Nat (%S, %s)" s (Z.to_string n)
| Mutez Region.{region; value = s,n} -> | Mutez Region.{region; value = s,n} ->
region, sprintf "Mutez (\"%s\", %s)" s (Z.to_string n) region, sprintf "Mutez (%S, %s)" s (Z.to_string n)
| Ident Region.{region; value} -> | Ident Region.{region; value} ->
region, sprintf "Ident %s" value region, sprintf "Ident %S" value
| Constr Region.{region; value} -> | Constr Region.{region; value} ->
region, sprintf "Constr %s" value region, sprintf "Constr %S" value
| Attr Region.{region; value} ->
region, sprintf "Attr %S" value
| Lang Region.{region; value} ->
region, sprintf "Lang %S" (value.Region.value)
(* Symbols *) (* Symbols *)
@ -133,7 +137,6 @@ let proj_token = function
| PLUS region -> region, "PLUS" | PLUS region -> region, "PLUS"
| SLASH region -> region, "SLASH" | SLASH region -> region, "SLASH"
| TIMES region -> region, "TIMES" | TIMES region -> region, "TIMES"
| PERCENT region -> region, "PERCENT"
| LPAR region -> region, "LPAR" | LPAR region -> region, "LPAR"
| RPAR region -> region, "RPAR" | RPAR region -> region, "RPAR"
| LBRACKET region -> region, "LBRACKET" | LBRACKET region -> region, "LBRACKET"
@ -170,7 +173,6 @@ let proj_token = function
| Type region -> region, "Type" | Type region -> region, "Type"
| C_None region -> region, "C_None" | C_None region -> region, "C_None"
| C_Some region -> region, "C_Some" | C_Some region -> region, "C_Some"
| Attr Region.{region; value} -> region, sprintf "Attr %s" value
| EOF region -> region, "EOF" | EOF region -> region, "EOF"
let to_lexeme = function let to_lexeme = function
@ -185,6 +187,7 @@ let to_lexeme = function
| Ident id -> id.Region.value | Ident id -> id.Region.value
| Constr id -> id.Region.value | Constr id -> id.Region.value
| Attr a -> a.Region.value | Attr a -> a.Region.value
| Lang lang -> Region.(lang.value.value)
(* Symbols *) (* Symbols *)
@ -193,7 +196,6 @@ let to_lexeme = function
| PLUS _ -> "+" | PLUS _ -> "+"
| SLASH _ -> "/" | SLASH _ -> "/"
| TIMES _ -> "*" | TIMES _ -> "*"
| PERCENT _ -> "%"
| LPAR _ -> "(" | LPAR _ -> "("
| RPAR _ -> ")" | RPAR _ -> ")"
| LBRACKET _ -> "[" | LBRACKET _ -> "["
@ -432,7 +434,6 @@ let mk_sym lexeme region =
| "+" -> Ok (PLUS region) | "+" -> Ok (PLUS region)
| "/" -> Ok (SLASH region) | "/" -> Ok (SLASH region)
| "*" -> Ok (TIMES region) | "*" -> Ok (TIMES region)
| "%" -> Ok (PERCENT region)
| "[" -> Ok (LBRACKET region) | "[" -> Ok (LBRACKET region)
| "]" -> Ok (RBRACKET region) | "]" -> Ok (RBRACKET region)
| "{" -> Ok (LBRACE region) | "{" -> Ok (LBRACE region)
@ -488,6 +489,10 @@ let mk_attr header lexeme region =
Ok (Attr Region.{value=lexeme; region}) Ok (Attr Region.{value=lexeme; region})
else Error Invalid_attribute else Error Invalid_attribute
(* Language injection *)
let mk_lang lang region = Lang Region.{value=lang; region}
(* Predicates *) (* Predicates *)
let is_string = function String _ -> true | _ -> false let is_string = function String _ -> true | _ -> false
@ -549,7 +554,7 @@ let check_right_context token next_token buffer : unit =
else () else ()
else else
if is_bytes token if is_bytes token
then if is_string next || is_ident next then if is_string next || is_ident next
then fail region Missing_break then fail region Missing_break
else if is_int next else if is_int next
then fail region Odd_lengthed_bytes then fail region Odd_lengthed_bytes

20
src/passes/01-parser/reasonligo/ParToken.mly
View File

@ -5,15 +5,16 @@
(* Literals *) (* Literals *)
%token <string Region.reg> String "<string>" %token <string Region.reg> String "<string>"
%token <string Region.reg> Verbatim "<verbatim>" %token <string Region.reg> Verbatim "<verbatim>"
%token <(LexToken.lexeme * Hex.t) Region.reg> Bytes "<bytes>" %token <(LexToken.lexeme * Hex.t) Region.reg> Bytes "<bytes>"
%token <(string * Z.t) Region.reg> Int "<int>" %token <(string * Z.t) Region.reg> Int "<int>"
%token <(string * Z.t) Region.reg> Nat "<nat>" %token <(string * Z.t) Region.reg> Nat "<nat>"
%token <(string * Z.t) Region.reg> Mutez "<mutez>" %token <(string * Z.t) Region.reg> Mutez "<mutez>"
%token <string Region.reg> Ident "<ident>" %token <string Region.reg> Ident "<ident>"
%token <string Region.reg> Constr "<constr>" %token <string Region.reg> Constr "<constr>"
%token <string Region.reg> Attr "<attr>" %token <string Region.reg> Attr "<attr>"
%token <LexToken.lexeme Region.reg Region.reg> Lang "<lang>"
(* Symbols *) (* Symbols *)
@ -21,7 +22,6 @@
%token <Region.t> PLUS "+" %token <Region.t> PLUS "+"
%token <Region.t> SLASH "/" %token <Region.t> SLASH "/"
%token <Region.t> TIMES "*" %token <Region.t> TIMES "*"
%token <Region.t> PERCENT "%"
%token <Region.t> LPAR "(" %token <Region.t> LPAR "("
%token <Region.t> RPAR ")" %token <Region.t> RPAR ")"

41
src/passes/01-parser/reasonligo/Parser.mly
View File

@ -801,20 +801,20 @@ call_expr:
in ECall {region; value} } in ECall {region; value} }
common_expr: common_expr:
"<int>" { EArith (Int $1) } "<int>" { EArith (Int $1) }
| "<mutez>" { EArith (Mutez $1) } | "<mutez>" { EArith (Mutez $1) }
| "<nat>" { EArith (Nat $1) } | "<nat>" { EArith (Nat $1) }
| "<bytes>" { EBytes $1 } | "<bytes>" { EBytes $1 }
| "<ident>" | module_field { EVar $1 } | "<ident>" | module_field { EVar $1 }
| projection { EProj $1 } | projection { EProj $1 }
| "_" { EVar {value = "_"; region = $1} } | "_" { EVar {value = "_"; region = $1} }
| update_record { EUpdate $1 } | update_record { EUpdate $1 }
| "<string>" { EString (String $1) } | "<string>" { EString (String $1) }
| "<verbatim>" { EString (Verbatim $1) } | "<verbatim>" { EString (Verbatim $1) }
| unit { EUnit $1 } | unit { EUnit $1 }
| "false" { ELogic (BoolExpr (False $1)) } | "false" { ELogic (BoolExpr (False $1)) }
| "true" { ELogic (BoolExpr (True $1)) } | "true" { ELogic (BoolExpr (True $1)) }
| code_insert { ECodeInsert $1 } | code_inj { ECodeInj $1 }
core_expr_2: core_expr_2:
common_expr { $1 } common_expr { $1 }
@ -920,15 +920,10 @@ update_record:
rbrace = $6} rbrace = $6}
in {region; value} } in {region; value} }
code_insert: code_inj:
"[" "%" Constr expr "]" { "<lang>" expr "]" {
let region = cover $1 $5 in let region = cover $1.region $3
let value = { and value = {language=$1; code=$2; rbracket=$3}
lbracket =$1;
percent =$2;
language =$3;
code =$4;
rbracket =$5}
in {region; value} } in {region; value} }
expr_with_let_expr: expr_with_let_expr:

10
src/passes/01-parser/reasonligo/Pretty.ml
View File

@ -159,7 +159,7 @@ and pp_expr = function
| ELetIn e -> pp_let_in e | ELetIn e -> pp_let_in e
| EFun e -> pp_fun e | EFun e -> pp_fun e
| ESeq e -> pp_seq e | ESeq e -> pp_seq e
| ECodeInsert e -> pp_code_insert e | ECodeInj e -> pp_code_inj e
and pp_case_expr {value; _} = and pp_case_expr {value; _} =
let {expr; cases; _} = value in let {expr; cases; _} = value in
@ -320,11 +320,11 @@ and pp_update {value; _} =
string "{..." ^^ record ^^ string "," string "{..." ^^ record ^^ string ","
^^ nest 2 (break 1 ^^ updates ^^ string "}") ^^ nest 2 (break 1 ^^ updates ^^ string "}")
and pp_code_insert {value; _} = and pp_code_inj {value; _} =
let {language; code; _} = value in let {language; code; _} = value in
let language = pp_string language let language = pp_string language.value
and code = pp_expr code in and code = pp_expr code in
string "[%" ^^ language ^^ string " " ^^ code ^^ string " ]" string "[%" ^^ language ^/^ code ^^ string "]"
and pp_field_path_assign {value; _} = and pp_field_path_assign {value; _} =
let {field_path; field_expr; _} = value in let {field_path; field_expr; _} = value in

1372
src/passes/01-parser/reasonligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

1
src/passes/01-parser/shared/Lexer.mli
View File

@ -79,6 +79,7 @@ module type TOKEN =
val mk_bytes : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token
val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result
val mk_lang : lexeme Region.reg -> Region.t -> token
val eof : Region.t -> token val eof : Region.t -> token
(* Predicates *) (* Predicates *)

13
src/passes/01-parser/shared/Lexer.mll
View File

@ -43,6 +43,7 @@ module type TOKEN =
val mk_bytes : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token
val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result
val mk_lang : lexeme Region.reg -> Region.t -> token
val eof : Region.t -> token val eof : Region.t -> token
(* Predicates *) (* Predicates *)
@ -273,6 +274,15 @@ module Make (Token : TOKEN) : (S with module Token = Token) =
let token = Token.mk_constr lexeme region let token = Token.mk_constr lexeme region
in state#enqueue token in state#enqueue token
let mk_lang lang state buffer =
let region, _, state = state#sync buffer in
let start = region#start#shift_bytes 1 in
let stop = region#stop in
let lang_reg = Region.make ~start ~stop in
let lang = Region.{value=lang; region=lang_reg} in
let token = Token.mk_lang lang region
in state#enqueue token
let mk_sym state buffer = let mk_sym state buffer =
let region, lexeme, state = state#sync buffer in let region, lexeme, state = state#sync buffer in
match Token.mk_sym lexeme region with match Token.mk_sym lexeme region with
@ -314,7 +324,7 @@ let esc = "\\n" | "\\\"" | "\\\\" | "\\b"
let common_sym = ';' | ',' | '(' | ')' | '[' | ']' | '{' | '}' let common_sym = ';' | ',' | '(' | ')' | '[' | ']' | '{' | '}'
| '=' | ':' | '|' | "->" | '.' | '_' | '^' | '=' | ':' | '|' | "->" | '.' | '_' | '^'
| '+' | '-' | '*' | '/' | '%' | '<' | "<=" | '>' | ">=" | '+' | '-' | '*' | '/' | '<' | "<=" | '>' | ">="
let pascaligo_sym = "=/=" | '#' | ":=" let pascaligo_sym = "=/=" | '#' | ":="
let cameligo_sym = "<>" | "::" | "||" | "&&" let cameligo_sym = "<>" | "::" | "||" | "&&"
let reasonligo_sym = '!' | "=>" | "!=" | "==" | "++" | "..." | "||" | "&&" let reasonligo_sym = '!' | "=>" | "!=" | "==" | "++" | "..." | "||" | "&&"
@ -388,6 +398,7 @@ and scan state = parse
| eof { mk_eof state lexbuf } | eof { mk_eof state lexbuf }
| "[@" (attr as a) "]" { mk_attr "[@" a state lexbuf } | "[@" (attr as a) "]" { mk_attr "[@" a state lexbuf }
| "[@@" (attr as a) "]" { mk_attr "[@@" a state lexbuf } | "[@@" (attr as a) "]" { mk_attr "[@@" a state lexbuf }
| "[%" (attr as l) { mk_lang l state lexbuf }
(* Management of #include preprocessing directives (* Management of #include preprocessing directives

14
src/passes/02-concrete_to_imperative/cameligo.ml
View File

@ -487,19 +487,17 @@ in trace (abstracting_expr_tracer t) @@
return @@ e_sequence a e1' return @@ e_sequence a e1'
in List.fold_left apply expr' more) in List.fold_left apply expr' more)
) )
| ECond c -> ( | ECond c ->
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = compile_expression c.test in let%bind expr = compile_expression c.test in
let%bind match_true = compile_expression c.ifso in let%bind match_true = compile_expression c.ifso in
let%bind match_false = compile_expression c.ifnot in let%bind match_false = compile_expression c.ifnot in
return @@ e_cond ~loc expr match_true match_false return @@ e_cond ~loc expr match_true match_false
) | ECodeInj ci ->
| ECodeInsert ci -> ( let ci, loc = r_split ci in
let (ci, loc) = r_split ci in let language = ci.language.value.value in
let language = ci.language.value in let%bind code = compile_expression ci.code
let%bind code = compile_expression ci.code in in ok @@ e_raw_code ~loc language code
return @@ e_raw_code ~loc language code
)
and compile_fun lamb' : (expr , abs_error) result = and compile_fun lamb' : (expr , abs_error) result =
let return x = ok x in let return x = ok x in

98
src/passes/02-concrete_to_imperative/pascaligo.ml
View File

@ -16,8 +16,9 @@ open Operators.Concrete_to_imperative.Pascaligo
let r_split = Location.r_split let r_split = Location.r_split
let return = ok
let rec compile_type_expression : CST.type_expr -> _ result = fun te -> let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
let return te = ok @@ te in
match te with match te with
TSum sum -> TSum sum ->
let (nsepseq, loc) = r_split sum in let (nsepseq, loc) = r_split sum in
@ -36,7 +37,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
let aux (field : CST.field_decl CST.reg) = let aux (field : CST.field_decl CST.reg) =
let (f, _) = r_split field in let (f, _) = r_split field in
let%bind type_expr = compile_type_expression f.field_type in let%bind type_expr = compile_type_expression f.field_type in
ok @@ (f.field_name.value,type_expr) return @@ (f.field_name.value,type_expr)
in in
let%bind record = bind_map_list aux lst in let%bind record = bind_map_list aux lst in
return @@ t_record_ez ~loc record return @@ t_record_ez ~loc record
@ -66,7 +67,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
get_t_string_singleton_opt d in get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in let%bind c' = compile_type_expression c in
ok @@ t_michelson_or ~loc a' b' c' d' return @@ t_michelson_or ~loc a' b' c' d'
) )
| _ -> fail @@ michelson_type_wrong_arity loc operator.value) | _ -> fail @@ michelson_type_wrong_arity loc operator.value)
| "michelson_pair" -> | "michelson_pair" ->
@ -81,7 +82,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
get_t_string_singleton_opt d in get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in let%bind c' = compile_type_expression c in
ok @@ t_michelson_pair ~loc a' b' c' d' return @@ t_michelson_pair ~loc a' b' c' d'
) )
| _ -> fail @@ michelson_type_wrong_arity loc operator.value) | _ -> fail @@ michelson_type_wrong_arity loc operator.value)
| _ -> | _ ->
@ -119,12 +120,11 @@ let compile_selection (selection : CST.selection) =
(Access_tuple index, loc) (Access_tuple index, loc)
let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error) result = fun e -> let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error) result = fun e ->
let return e = ok @@ e in
let compile_tuple_expression (tuple_expr : CST.tuple_expr) = let compile_tuple_expression (tuple_expr : CST.tuple_expr) =
let (lst, loc) = r_split tuple_expr in let (lst, loc) = r_split tuple_expr in
let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in
match lst with match lst with
hd::[] -> return @@ hd hd::[] -> return hd
| lst -> return @@ e_tuple ~loc lst | lst -> return @@ e_tuple ~loc lst
in in
let compile_path (path : CST.path) = let compile_path (path : CST.path) =
@ -245,7 +245,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (fa, _) = r_split fa in let (fa, _) = r_split fa in
let (name, _) = r_split fa.field_name in let (name, _) = r_split fa.field_name in
let%bind expr = compile_expression fa.field_expr in let%bind expr = compile_expression fa.field_expr in
ok @@ (name, expr) return (name, expr)
in in
let%bind record = bind_map_list aux @@ npseq_to_list record.ne_elements in let%bind record = bind_map_list aux @@ npseq_to_list record.ne_elements in
return @@ e_record_ez ~loc record return @@ e_record_ez ~loc record
@ -271,7 +271,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
(Access_record proj.struct_name.value)::path (Access_record proj.struct_name.value)::path
) )
in in
ok @@ (path, expr, loc) return (path, expr, loc)
in in
let%bind updates = bind_map_list aux @@ npseq_to_list updates.ne_elements in let%bind updates = bind_map_list aux @@ npseq_to_list updates.ne_elements in
let aux e (path, update, loc) = e_update ~loc e path update in let aux e (path, update, loc) = e_update ~loc e path update in
@ -283,12 +283,12 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (p, _) = r_split p in let (p, _) = r_split p in
let (var, _loc) = r_split p.var in let (var, _loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in
ok @@ (var, p_type) return (var, p_type)
| ParamVar p -> | ParamVar p ->
let (p, _) = r_split p in let (p, _) = r_split p in
let (var, _loc) = r_split p.var in let (var, _loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in
ok @@ (var, p_type) return (var, p_type)
in in
let (func, loc) = r_split func in let (func, loc) = r_split func in
let (param, loc_par) = r_split func.param in let (param, loc_par) = r_split func.param in
@ -394,7 +394,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (binding, _) = r_split binding in let (binding, _) = r_split binding in
let%bind key = compile_expression binding.source in let%bind key = compile_expression binding.source in
let%bind value = compile_expression binding.image in let%bind value = compile_expression binding.image in
ok @@ (key,value) return (key,value)
in in
let%bind map = bind_map_list aux lst in let%bind map = bind_map_list aux lst in
return @@ e_map ~loc map return @@ e_map ~loc map
@ -406,27 +406,26 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (binding, _) = r_split binding in let (binding, _) = r_split binding in
let%bind key = compile_expression binding.source in let%bind key = compile_expression binding.source in
let%bind value = compile_expression binding.image in let%bind value = compile_expression binding.image in
ok @@ (key,value) return (key,value)
in in
let%bind map = bind_map_list aux lst in let%bind map = bind_map_list aux lst in
return @@ e_big_map ~loc map return @@ e_big_map ~loc map
) )
| ECodeInsert ci -> | ECodeInj ci ->
let (ci, loc) = r_split ci in let (ci, loc) = r_split ci in
let (language, _) = r_split ci.language in let (language, _) = r_split ci.language in
let (language, _) = r_split language in
let%bind code = compile_expression ci.code in let%bind code = compile_expression ci.code in
return @@ e_raw_code ~loc language code return @@ e_raw_code ~loc language code
and compile_matching_expr : type a.(a -> _ result) -> a CST.case_clause CST.reg List.Ne.t -> _ = and compile_matching_expr : type a.(a -> _ result) -> a CST.case_clause CST.reg List.Ne.t -> _ =
fun compiler cases -> fun compiler cases ->
let compile_pattern pattern = ok @@ pattern let compile_pattern pattern = return pattern in
in
let return e = ok @@ e in
let compile_simple_pattern (pattern : CST.pattern) = let compile_simple_pattern (pattern : CST.pattern) =
match pattern with match pattern with
PVar var -> PVar var ->
let (var, _) = r_split var in let (var, _) = r_split var in
ok @@ Var.of_name var return @@ Var.of_name var
| _ -> fail @@ unsupported_non_var_pattern pattern | _ -> fail @@ unsupported_non_var_pattern pattern
in in
let compile_list_pattern (cases : (CST.pattern * _) list) = let compile_list_pattern (cases : (CST.pattern * _) list) =
@ -435,12 +434,12 @@ fun compiler cases ->
| [(PList PCons cons, econs);(PList PNil _, match_nil)] -> | [(PList PCons cons, econs);(PList PNil _, match_nil)] ->
let (cons,_) = r_split cons in let (cons,_) = r_split cons in
let%bind (hd,tl) = match snd @@ List.split (snd cons) with let%bind (hd,tl) = match snd @@ List.split (snd cons) with
tl::[] -> ok @@ (fst cons,tl) tl::[] -> return (fst cons,tl)
| _ -> fail @@ unsupported_deep_list_patterns @@ fst cons | _ -> fail @@ unsupported_deep_list_patterns @@ fst cons
in in
let%bind (hd,tl) = bind_map_pair compile_simple_pattern (hd,tl) in let%bind (hd,tl) = bind_map_pair compile_simple_pattern (hd,tl) in
let match_cons = (hd,tl,econs) in let match_cons = (hd,tl,econs) in
ok @@ (match_nil,match_cons) return (match_nil,match_cons)
| _ -> fail @@ unsupported_deep_list_patterns @@ fst @@ List.hd cases | _ -> fail @@ unsupported_deep_list_patterns @@ fst @@ List.hd cases
in in
let compile_simple_tuple_pattern (tuple : CST.tuple_pattern) = let compile_simple_tuple_pattern (tuple : CST.tuple_pattern) =
@ -455,22 +454,22 @@ fun compiler cases ->
( match c with ( match c with
PUnit _ -> PUnit _ ->
fail @@ unsupported_pattern_type constr fail @@ unsupported_pattern_type constr
| PFalse _ -> ok @@ (Constructor "false", Var.of_name "_") | PFalse _ -> return (Constructor "false", Var.of_name "_")
| PTrue _ -> ok @@ (Constructor "true", Var.of_name "_") | PTrue _ -> return (Constructor "true", Var.of_name "_")
| PNone _ -> ok @@ (Constructor "None", Var.of_name "_") | PNone _ -> return (Constructor "None", Var.of_name "_")
| PSomeApp some -> | PSomeApp some ->
let (some,_) = r_split some in let (some,_) = r_split some in
let (_, pattern) = some in let (_, pattern) = some in
let (pattern,_) = r_split pattern in let (pattern,_) = r_split pattern in
let%bind pattern = compile_simple_pattern pattern.inside in let%bind pattern = compile_simple_pattern pattern.inside in
ok @@ (Constructor "Some", pattern) return (Constructor "Some", pattern)
| PConstrApp constr -> | PConstrApp constr ->
let (constr, _) = r_split constr in let (constr, _) = r_split constr in
let (constr, patterns) = constr in let (constr, patterns) = constr in
let (constr, _) = r_split constr in let (constr, _) = r_split constr in
let%bind pattern = bind_map_option compile_simple_tuple_pattern patterns in let%bind pattern = bind_map_option compile_simple_tuple_pattern patterns in
let pattern = Option.unopt ~default:(Var.of_name "_") pattern in let pattern = Option.unopt ~default:(Var.of_name "_") pattern in
ok (Constructor constr, pattern) return (Constructor constr, pattern)
) )
| _ -> fail @@ unsupported_pattern_type constr | _ -> fail @@ unsupported_pattern_type constr
in in
@ -478,7 +477,7 @@ fun compiler cases ->
let (case, _loc) = r_split case in let (case, _loc) = r_split case in
let%bind pattern = compile_pattern case.pattern in let%bind pattern = compile_pattern case.pattern in
let%bind expr = compiler case.rhs in let%bind expr = compiler case.rhs in
ok (pattern, expr) return (pattern, expr)
in in
let%bind cases = bind_map_ne_list aux cases in let%bind cases = bind_map_ne_list aux cases in
match cases with match cases with
@ -497,10 +496,9 @@ fun compiler cases ->
return @@ AST.Match_variant (List.combine constrs lst) return @@ AST.Match_variant (List.combine constrs lst)
| (p, _), _ -> fail @@ unsupported_pattern_type p | (p, _), _ -> fail @@ unsupported_pattern_type p
let compile_attribute_declaration attributes = let compile_attribute_declaration = function
match attributes with None -> return false
None -> ok @@ false | Some _ -> return true
| Some _ -> ok @@ true
let compile_parameters (params : CST.parameters) = let compile_parameters (params : CST.parameters) =
let compile_param_decl (param : CST.param_decl) = let compile_param_decl (param : CST.param_decl) =
@ -509,12 +507,12 @@ let compile_parameters (params : CST.parameters) =
let (pc, _loc) = r_split pc in let (pc, _loc) = r_split pc in
let (var, _) = r_split pc.var in let (var, _) = r_split pc.var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pc.param_type in let%bind param_type = bind_map_option (compile_type_expression <@ snd) pc.param_type in
ok @@ (var, param_type) return (var, param_type)
| ParamVar pv -> | ParamVar pv ->
let (pv, _loc) = r_split pv in let (pv, _loc) = r_split pv in
let (var, _) = r_split pv.var in let (var, _) = r_split pv.var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pv.param_type in let%bind param_type = bind_map_option (compile_type_expression <@ snd) pv.param_type in
ok @@ (var, param_type) return (var, param_type)
in in
let (params, _loc) = r_split params in let (params, _loc) = r_split params in
let params = npseq_to_list params.inside in let params = npseq_to_list params.inside in
@ -522,15 +520,15 @@ let compile_parameters (params : CST.parameters) =
let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction -> let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction ->
let return expr = match next with let return expr = match next with
Some e -> ok @@ e_sequence expr e Some e -> return @@ e_sequence expr e
| None -> ok @@ expr | None -> return expr
in in
let compile_tuple_expression (tuple_expr : CST.tuple_expr) = let compile_tuple_expression (tuple_expr : CST.tuple_expr) =
let (lst, loc) = r_split tuple_expr in let (lst, loc) = r_split tuple_expr in
let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in
match lst with match lst with
hd::[] -> ok @@ hd hd::[] -> return hd
| lst -> ok @@ e_tuple ~loc lst | lst -> return @@ e_tuple ~loc lst
in in
let compile_if_clause : ?next:AST.expression -> CST.if_clause -> _ = fun ?next if_clause -> let compile_if_clause : ?next:AST.expression -> CST.if_clause -> _ = fun ?next if_clause ->
match if_clause with match if_clause with
@ -552,14 +550,14 @@ let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ resu
Name var -> Name var ->
let (var,loc) = r_split var in let (var,loc) = r_split var in
let str = e_variable_ez ~loc var in let str = e_variable_ez ~loc var in
ok @@ (str, var, []) ok (str, var, [])
| Path proj -> | Path proj ->
let (proj, loc) = r_split proj in let (proj, loc) = r_split proj in
let (var, loc_var) = r_split proj.struct_name in let (var, loc_var) = r_split proj.struct_name in
let path = List.map compile_selection @@ npseq_to_list proj.field_path in let path = List.map compile_selection @@ npseq_to_list proj.field_path in
let (path, _) = List.split path in let (path, _) = List.split path in
let str = e_accessor ~loc (e_variable_ez ~loc:loc_var var) path in let str = e_accessor ~loc (e_variable_ez ~loc:loc_var var) path in
ok @@ (str, var, path) ok (str, var, path)
in in
let compile_lhs : CST.lhs -> _ = fun lhs -> let compile_lhs : CST.lhs -> _ = fun lhs ->
match lhs with match lhs with
@ -716,24 +714,23 @@ and compile_statement : ?next:AST.expression -> CST.attr_decl option -> CST.stat
match statement with match statement with
Instr i -> Instr i ->
let%bind i = compile_instruction ?next i in let%bind i = compile_instruction ?next i in
ok @@ (Some i, None) return (Some i, None)
| Data dd -> | Data dd ->
let next = Option.unopt ~default:(e_skip ()) next in let next = Option.unopt ~default:(e_skip ()) next in
let%bind dd = compile_data_declaration ~next ?attr dd in let%bind dd = compile_data_declaration ~next ?attr dd in
ok @@ (Some dd, None) return (Some dd, None)
| Attr at -> ok @@ (next, Some at) | Attr at -> return (next, Some at)
and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun ?next block -> and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun ?next block ->
let (block', _loc) = r_split block in let (block', _loc) = r_split block in
let statements = npseq_to_list block'.statements in let statements = npseq_to_list block'.statements in
let aux (next,attr) statement = let aux (next,attr) statement =
let%bind (statement, attr) = compile_statement ?next attr statement in let%bind (statement, attr) = compile_statement ?next attr statement in
ok @@ (statement,attr) return (statement,attr)
in in
let%bind (block', _) = bind_fold_right_list aux (next,None) statements in let%bind (block', _) = bind_fold_right_list aux (next,None) statements in
match block' with match block' with
Some block -> ok @@ block Some block -> return block
| None -> fail @@ block_start_with_attribute block | None -> fail @@ block_start_with_attribute block
and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; return=r; attributes}: CST.fun_decl) = and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; return=r; attributes}: CST.fun_decl) =
@ -743,7 +740,7 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret
let%bind param = compile_parameters param in let%bind param = compile_parameters param in
let%bind r = compile_expression r in let%bind r = compile_expression r in
let (param, param_type) = List.split param in let (param, param_type) = List.split param in
let%bind body = Option.unopt ~default:(ok @@ r) @@ let%bind body = Option.unopt ~default:(return r) @@
Option.map (compile_block ~next:r <@ fst) block_with Option.map (compile_block ~next:r <@ fst) block_with
in in
(* This handle the parameter case *) (* This handle the parameter case *)
@ -773,16 +770,17 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret
let%bind func = match kwd_recursive with let%bind func = match kwd_recursive with
Some reg -> Some reg ->
let%bind fun_type = trace_option (untyped_recursive_fun loc) @@ fun_type in let%bind fun_type = trace_option (untyped_recursive_fun loc) @@ fun_type in
ok @@ e_recursive_ez ~loc:(Location.lift reg) fun_name fun_type lambda return @@ e_recursive_ez ~loc:(Location.lift reg) fun_name fun_type lambda
| None -> | None ->
ok @@ make_e ~loc @@ E_lambda lambda return @@ make_e ~loc @@ E_lambda lambda
in in
ok @@ (fun_name,fun_type, attr, func) return (fun_name,fun_type, attr, func)
(* Currently attributes are badly proccess, some adaptation are made to accomodate this (* Currently attributes are badly proccess, some adaptation are made to accomodate this
maked as ATR *) maked as ATR *)
let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = fun (attr, lst) decl -> let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = fun (attr, lst) decl ->
let return ?attr reg decl = ok @@ (attr, (Location.wrap ~loc:(Location.lift reg) decl)::lst) in (*ATR*) let return ?attr reg decl =
return (attr, (Location.wrap ~loc:(Location.lift reg) decl)::lst) in (*ATR*)
match decl with match decl with
TypeDecl {value={name; type_expr; _};region} -> TypeDecl {value={name; type_expr; _};region} ->
(* Todo : if attr isn't none, send warning *) (* Todo : if attr isn't none, send warning *)
@ -800,7 +798,7 @@ let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = f
let value = {value with attributes = attr} in (*ATR*) let value = {value with attributes = attr} in (*ATR*)
let%bind (fun_name,fun_type,attr,lambda) = compile_fun_decl value in let%bind (fun_name,fun_type,attr,lambda) = compile_fun_decl value in
return region @@ AST.Declaration_constant (Var.of_name fun_name, fun_type, attr, lambda) return region @@ AST.Declaration_constant (Var.of_name fun_name, fun_type, attr, lambda)
| AttrDecl decl -> ok @@ (Some decl, lst) (*ATR*) | AttrDecl decl -> ok (Some decl, lst) (*ATR*)
(* This should be change to the commented function when attributes are fixed (* This should be change to the commented function when attributes are fixed
let compile_program : CST.ast -> _ result = fun t -> let compile_program : CST.ast -> _ result = fun t ->
@ -811,4 +809,4 @@ let compile_program : CST.ast -> _ result =
let declarations = List.rev @@ nseq_to_list t.decl in let declarations = List.rev @@ nseq_to_list t.decl in
let attr = (None, []) in let attr = (None, []) in
let%bind (_, declarations) = bind_fold_list compile_declaration attr declarations in let%bind (_, declarations) = bind_fold_list compile_declaration attr declarations in
ok @@ declarations return declarations