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

Fixed the printing of some AST nodes.

Browse Source
This commit is contained in:
Christian Rinderknecht 2019-11-06 17:23:49 +01:00
parent bd6ce2f28c
commit fe90246e3a
14 changed files with 570 additions and 615 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/passes/1-parser/ligodity/ParserLog.ml
View File

@ -878,13 +878,13 @@ and pp_arith_expr buffer ~pad:(_,pc as pad) = function
pp_node buffer ~pad "Mutez"; pp_node buffer ~pad "Mutez";
pp_int buffer ~pad m pp_int buffer ~pad m
and pp_e_logic buffer ~pad = function and pp_e_logic buffer ~pad:(_,pc as pad) = function
BoolExpr e -> BoolExpr e ->
pp_node buffer ~pad "BoolExpr"; pp_node buffer ~pad "BoolExpr";
pp_bool_expr buffer ~pad e pp_bool_expr buffer ~pad:(mk_pad 1 0 pc) e
| CompExpr e -> | CompExpr e ->
pp_node buffer ~pad "CompExpr"; pp_node buffer ~pad "CompExpr";
pp_comp_expr buffer ~pad e pp_comp_expr buffer ~pad:(mk_pad 1 0 pc) e
and pp_bool_expr buffer ~pad:(_,pc as pad) = function and pp_bool_expr buffer ~pad:(_,pc as pad) = function
Or {value; region} -> Or {value; region} ->
@ -892,13 +892,12 @@ and pp_bool_expr buffer ~pad:(_,pc as pad) = function
| And {value; region} -> | And {value; region} ->
pp_bin_op "And" region buffer ~pad value pp_bin_op "And" region buffer ~pad value
| Not {value; _} -> | Not {value; _} ->
let _, pc as pad = mk_pad 1 0 pc in
pp_node buffer ~pad "Not"; pp_node buffer ~pad "Not";
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg
| False region -> | False region ->
pp_loc_node buffer ~pad:(mk_pad 1 0 pc) "False" region pp_loc_node buffer ~pad "False" region
| True region -> | True region ->
pp_loc_node buffer ~pad:(mk_pad 1 0 pc) "True" region pp_loc_node buffer ~pad "True" region
and pp_comp_expr buffer ~pad = function and pp_comp_expr buffer ~pad = function
Lt {value; region} -> Lt {value; region} ->

98
src/passes/1-parser/pascaligo/AST.ml
View File

@ -191,13 +191,13 @@ and type_expr =
| TApp of (type_name * type_tuple) reg | TApp of (type_name * type_tuple) reg
| TFun of (type_expr * arrow * type_expr) reg | TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg | TPar of type_expr par reg
| TAlias of variable | TVar of variable
and cartesian = (type_expr, times) nsepseq reg and cartesian = (type_expr, times) nsepseq reg
and variant = { and variant = {
constr : constr; constr : constr;
args : (kwd_of * type_expr) option arg : (kwd_of * type_expr) option
} }
and field_decl = { and field_decl = {
@ -211,17 +211,18 @@ and type_tuple = (type_expr, comma) nsepseq par reg
(* Function and procedure declarations *) (* Function and procedure declarations *)
and fun_decl = { and fun_decl = {
kwd_function : kwd_function; kwd_function : kwd_function;
name : variable; name : variable;
param : parameters; param : parameters;
colon : colon; colon : colon;
ret_type : type_expr; ret_type : type_expr;
kwd_is : kwd_is; kwd_is : kwd_is;
local_decls : local_decl list; local_decls : local_decl list;
block : block reg option; block : block reg option;
kwd_with : kwd_with option; kwd_with : kwd_with option;
return : expr; return : expr;
terminator : semi option } terminator : semi option
}
and parameters = (param_decl, semi) nsepseq par reg and parameters = (param_decl, semi) nsepseq par reg
@ -456,7 +457,7 @@ and 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_expr | ERecord of field_assign reg ne_injection reg
| EProj of projection reg | EProj of projection reg
| EMap of map_expr | EMap of map_expr
| EVar of Lexer.lexeme reg | EVar of Lexer.lexeme reg
@ -497,7 +498,7 @@ and closing =
and map_expr = and map_expr =
MapLookUp of map_lookup reg MapLookUp of map_lookup reg
| MapInj of binding reg injection reg | MapInj of binding reg injection reg
| BigMapInj of binding reg injection reg | BigMapInj of binding reg injection reg
and map_lookup = { and map_lookup = {
path : path; path : path;
@ -554,19 +555,15 @@ and string_expr =
| String of Lexer.lexeme reg | String of Lexer.lexeme reg
and list_expr = and list_expr =
Cons of cons bin_op reg ECons of cons bin_op reg
| List of expr injection reg | EListComp of expr injection reg
| Nil of nil | ENil of kwd_nil
and nil = kwd_nil
and constr_expr = and constr_expr =
SomeApp of (c_Some * arguments) reg SomeApp of (c_Some * arguments) reg
| NoneExpr of none_expr | NoneExpr of c_None
| ConstrApp of (constr * arguments option) reg | ConstrApp of (constr * arguments option) reg
and record_expr = field_assign reg injection reg
and field_assign = { and field_assign = {
field_name : field_name; field_name : field_name;
equal : equal; equal : equal;
@ -585,8 +582,6 @@ and selection =
and tuple_expr = (expr, comma) nsepseq par reg and tuple_expr = (expr, comma) nsepseq par reg
and none_expr = c_None
and fun_call = (fun_name * arguments) reg and fun_call = (fun_name * arguments) reg
and arguments = tuple_expr and arguments = tuple_expr
@ -594,28 +589,31 @@ and arguments = tuple_expr
(* Patterns *) (* Patterns *)
and pattern = and pattern =
PCons of (pattern, cons) nsepseq reg PConstr of constr_pattern
| PConstr of (constr * tuple_pattern option) reg
| PVar of Lexer.lexeme reg | PVar of Lexer.lexeme reg
| PWild of wild | PWild of wild
| PInt of (Lexer.lexeme * Z.t) reg | PInt of (Lexer.lexeme * Z.t) reg
| PNat of (Lexer.lexeme * Z.t) reg | PNat of (Lexer.lexeme * Z.t) reg
| PBytes of (Lexer.lexeme * Hex.t) reg | PBytes of (Lexer.lexeme * Hex.t) reg
| PString of Lexer.lexeme reg | PString of Lexer.lexeme reg
| PUnit of c_Unit
| PFalse of c_False
| PTrue of c_True
| PNone of c_None
| PSome of (c_Some * pattern par reg) reg
| PList of list_pattern | PList of list_pattern
| PTuple of tuple_pattern | PTuple of tuple_pattern
and constr_pattern =
PUnit of c_Unit
| PFalse of c_False
| PTrue of c_True
| PNone of c_None
| PSomeApp of (c_Some * pattern par reg) reg
| PConstrApp of (constr * tuple_pattern option) reg
and tuple_pattern = (pattern, comma) nsepseq par reg and tuple_pattern = (pattern, comma) nsepseq par reg
and list_pattern = and list_pattern =
Sugar of pattern injection reg PListComp of pattern injection reg
| PNil of kwd_nil | PNil of kwd_nil
| Raw of (pattern * cons * pattern) par reg | PParCons of (pattern * cons * pattern) par reg
| PCons of (pattern, cons) nsepseq reg
(* Projecting regions *) (* Projecting regions *)
@ -628,7 +626,7 @@ let type_expr_to_region = function
| TApp {region; _} | TApp {region; _}
| TFun {region; _} | TFun {region; _}
| TPar {region; _} | TPar {region; _}
| TAlias {region; _} -> region | TVar {region; _} -> region
let rec expr_to_region = function let rec expr_to_region = function
| ELogic e -> logic_expr_to_region e | ELogic e -> logic_expr_to_region e
@ -698,9 +696,9 @@ and string_expr_to_region = function
and annot_expr_to_region {region; _} = region and annot_expr_to_region {region; _} = region
and list_expr_to_region = function and list_expr_to_region = function
Cons {region; _} ECons {region; _}
| List {region; _} | EListComp {region; _}
| Nil region -> region | ENil region -> region
and constr_expr_to_region = function and constr_expr_to_region = function
NoneExpr region NoneExpr region
@ -733,26 +731,26 @@ let clause_block_to_region = function
| ShortBlock {region; _} -> region | ShortBlock {region; _} -> region
let if_clause_to_region = function let if_clause_to_region = function
ClauseInstr instr -> instr_to_region instr ClauseInstr instr -> instr_to_region instr
| ClauseBlock clause_block -> clause_block_to_region clause_block | ClauseBlock clause_block -> clause_block_to_region clause_block
let pattern_to_region = function let pattern_to_region = function
PCons {region; _} PVar {region; _}
| PVar {region; _}
| PWild region | PWild region
| PInt {region; _} | PInt {region; _}
| PNat {region; _} | PNat {region; _}
| PBytes {region; _} | PBytes {region; _}
| PString {region; _} | PString {region; _}
| PUnit region | PConstr PUnit region
| PFalse region | PConstr PFalse region
| PTrue region | PConstr PTrue region
| PNone region | PConstr PNone region
| PSome {region; _} | PConstr PSomeApp {region; _}
| PList Sugar {region; _} | PConstr PConstrApp {region; _}
| PList PListComp {region; _}
| PList PNil region | PList PNil region
| PList Raw {region; _} | PList PParCons {region; _}
| PConstr {region; _} | PList PCons {region; _}
| PTuple {region; _} -> region | PTuple {region; _} -> region
let local_decl_to_region = function let local_decl_to_region = function

43
src/passes/1-parser/pascaligo/AST.mli
View File

@ -182,13 +182,13 @@ and type_expr =
| TApp of (type_name * type_tuple) reg | TApp of (type_name * type_tuple) reg
| TFun of (type_expr * arrow * type_expr) reg | TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg | TPar of type_expr par reg
| TAlias of variable | TVar of variable
and cartesian = (type_expr, times) nsepseq reg and cartesian = (type_expr, times) nsepseq reg
and variant = { and variant = {
constr : constr; constr : constr;
args : (kwd_of * type_expr) option arg : (kwd_of * type_expr) option
} }
and field_decl = { and field_decl = {
@ -447,7 +447,7 @@ and 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_expr | ERecord of field_assign reg ne_injection reg
| EProj of projection reg | EProj of projection reg
| EMap of map_expr | EMap of map_expr
| EVar of Lexer.lexeme reg | EVar of Lexer.lexeme reg
@ -545,19 +545,15 @@ and string_expr =
| String of Lexer.lexeme reg | String of Lexer.lexeme reg
and list_expr = and list_expr =
Cons of cons bin_op reg ECons of cons bin_op reg
| List of expr injection reg | EListComp of expr injection reg
| Nil of nil | ENil of kwd_nil
and nil = kwd_nil
and constr_expr = and constr_expr =
SomeApp of (c_Some * arguments) reg SomeApp of (c_Some * arguments) reg
| NoneExpr of none_expr | NoneExpr of c_None
| ConstrApp of (constr * arguments option) reg | ConstrApp of (constr * arguments option) reg
and record_expr = field_assign reg injection reg
and field_assign = { and field_assign = {
field_name : field_name; field_name : field_name;
equal : equal; equal : equal;
@ -576,8 +572,6 @@ and selection =
and tuple_expr = (expr, comma) nsepseq par reg and tuple_expr = (expr, comma) nsepseq par reg
and none_expr = c_None
and fun_call = (fun_name * arguments) reg and fun_call = (fun_name * arguments) reg
and arguments = tuple_expr and arguments = tuple_expr
@ -585,28 +579,31 @@ and arguments = tuple_expr
(* Patterns *) (* Patterns *)
and pattern = and pattern =
PCons of (pattern, cons) nsepseq reg PConstr of constr_pattern
| PConstr of (constr * tuple_pattern option) reg
| PVar of Lexer.lexeme reg | PVar of Lexer.lexeme reg
| PWild of wild | PWild of wild
| PInt of (Lexer.lexeme * Z.t) reg | PInt of (Lexer.lexeme * Z.t) reg
| PNat of (Lexer.lexeme * Z.t) reg | PNat of (Lexer.lexeme * Z.t) reg
| PBytes of (Lexer.lexeme * Hex.t) reg | PBytes of (Lexer.lexeme * Hex.t) reg
| PString of Lexer.lexeme reg | PString of Lexer.lexeme reg
| PUnit of c_Unit
| PFalse of c_False
| PTrue of c_True
| PNone of c_None
| PSome of (c_Some * pattern par reg) reg
| PList of list_pattern | PList of list_pattern
| PTuple of tuple_pattern | PTuple of tuple_pattern
and constr_pattern =
PUnit of c_Unit
| PFalse of c_False
| PTrue of c_True
| PNone of c_None
| PSomeApp of (c_Some * pattern par reg) reg
| PConstrApp of (constr * tuple_pattern option) reg
and tuple_pattern = (pattern, comma) nsepseq par reg and tuple_pattern = (pattern, comma) nsepseq par reg
and list_pattern = and list_pattern =
Sugar of pattern injection reg PListComp of pattern injection reg
| PNil of kwd_nil | PNil of kwd_nil
| Raw of (pattern * cons * pattern) par reg | PParCons of (pattern * cons * pattern) par reg
| PCons of (pattern, cons) nsepseq reg
(* Projecting regions *) (* Projecting regions *)

2
src/passes/1-parser/pascaligo/Doc/pascaligo.md
View File

@ -956,7 +956,7 @@ functions, in the tradition of Pascal. For example,
begin begin
skip skip
end with i+1 end with i+1
const item : int = 0 const item : int = 0
begin begin
var temp : list (int) := nil; var temp : list (int) := nil;
for item in l for item in l

79
src/passes/1-parser/pascaligo/LexToken.mli
View File

@ -70,51 +70,50 @@ type t =
(* Keywords *) (* Keywords *)
| And of Region.t (* "and" *) | And of Region.t (* "and" *)
| Begin of Region.t (* "begin" *) | Begin of Region.t (* "begin" *)
| BigMap of Region.t (* "big_map" *) | BigMap of Region.t (* "big_map" *)
| Block of Region.t (* "block" *) | Block of Region.t (* "block" *)
| Case of Region.t (* "case" *) | Case of Region.t (* "case" *)
| Const of Region.t (* "const" *) | Const of Region.t (* "const" *)
| Contains of Region.t (* "contains" *) | Contains of Region.t (* "contains" *)
| Down of Region.t (* "down" *) | Down of Region.t (* "down" *)
| Else of Region.t (* "else" *) | Else of Region.t (* "else" *)
| End of Region.t (* "end" *) | End of Region.t (* "end" *)
| Fail of Region.t (* "fail" *) | Fail of Region.t (* "fail" *)
| For of Region.t (* "for" *) | False of Region.t (* "False" *)
| From of Region.t (* "from" *) | For of Region.t (* "for" *)
| Function of Region.t (* "function" *) | From of Region.t (* "from" *)
| If of Region.t (* "if" *) | Function of Region.t (* "function" *)
| In of Region.t (* "in" *) | If of Region.t (* "if" *)
| Is of Region.t (* "is" *) | In of Region.t (* "in" *)
| List of Region.t (* "list" *) | Is of Region.t (* "is" *)
| Map of Region.t (* "map" *) | List of Region.t (* "list" *)
| Mod of Region.t (* "mod" *) | Map of Region.t (* "map" *)
| Nil of Region.t (* "nil" *) | Mod of Region.t (* "mod" *)
| Not of Region.t (* "not" *) | Nil of Region.t (* "nil" *)
| Of of Region.t (* "of" *) | Not of Region.t (* "not" *)
| Or of Region.t (* "or" *) | Of of Region.t (* "of" *)
| Patch of Region.t (* "patch" *) | Or of Region.t (* "or" *)
| Procedure of Region.t (* "procedure" *) | Patch of Region.t (* "patch" *)
| Record of Region.t (* "record" *) | Record of Region.t (* "record" *)
| Remove of Region.t (* "remove" *) | Remove of Region.t (* "remove" *)
| Set of Region.t (* "set" *) | Set of Region.t (* "set" *)
| Skip of Region.t (* "skip" *) | Skip of Region.t (* "skip" *)
| Step of Region.t (* "step" *) | Step of Region.t (* "step" *)
| Then of Region.t (* "then" *) | Then of Region.t (* "then" *)
| To of Region.t (* "to" *) | To of Region.t (* "to" *)
| Type of Region.t (* "type" *) | True of Region.t (* "True" *)
| Var of Region.t (* "var" *) | Type of Region.t (* "type" *)
| While of Region.t (* "while" *) | Unit of Region.t (* "Unit" *)
| With of Region.t (* "with" *) | Var of Region.t (* "var" *)
| While of Region.t (* "while" *)
| With of Region.t (* "with" *)
(* Data constructors *) (* Data constructors *)
| C_False of Region.t (* "False" *)
| C_None of Region.t (* "None" *) | C_None of Region.t (* "None" *)
| C_Some of Region.t (* "Some" *) | C_Some of Region.t (* "Some" *)
| C_True of Region.t (* "True" *)
| C_Unit of Region.t (* "Unit" *)
(* Virtual tokens *) (* Virtual tokens *)

164
src/passes/1-parser/pascaligo/LexToken.mll
View File

@ -68,73 +68,50 @@ type t =
(* Keywords *) (* Keywords *)
| And of Region.t (* "and" *) | And of Region.t (* "and" *)
| Begin of Region.t (* "begin" *) | Begin of Region.t (* "begin" *)
| BigMap of Region.t (* "big_map" *) | BigMap of Region.t (* "big_map" *)
| Block of Region.t (* "block" *) | Block of Region.t (* "block" *)
| Case of Region.t (* "case" *) | Case of Region.t (* "case" *)
| Const of Region.t (* "const" *) | Const of Region.t (* "const" *)
| Contains of Region.t (* "contains" *) | Contains of Region.t (* "contains" *)
| Down of Region.t (* "down" *) | Down of Region.t (* "down" *)
| Else of Region.t (* "else" *) | Else of Region.t (* "else" *)
| End of Region.t (* "end" *) | End of Region.t (* "end" *)
| Fail of Region.t (* "fail" *) | Fail of Region.t (* "fail" *)
| For of Region.t (* "for" *) | False of Region.t (* "False" *)
| From of Region.t (* "from" *) | For of Region.t (* "for" *)
| Function of Region.t (* "function" *) | From of Region.t (* "from" *)
| If of Region.t (* "if" *) | Function of Region.t (* "function" *)
| In of Region.t (* "in" *) | If of Region.t (* "if" *)
| Is of Region.t (* "is" *) | In of Region.t (* "in" *)
| List of Region.t (* "list" *) | Is of Region.t (* "is" *)
| Map of Region.t (* "map" *) | List of Region.t (* "list" *)
| Mod of Region.t (* "mod" *) | Map of Region.t (* "map" *)
| Nil of Region.t (* "nil" *) | Mod of Region.t (* "mod" *)
| Not of Region.t (* "not" *) | Nil of Region.t (* "nil" *)
| Of of Region.t (* "of" *) | Not of Region.t (* "not" *)
| Or of Region.t (* "or" *) | Of of Region.t (* "of" *)
| Patch of Region.t (* "patch" *) | Or of Region.t (* "or" *)
| Procedure of Region.t (* "procedure" *) | Patch of Region.t (* "patch" *)
| Record of Region.t (* "record" *) | Record of Region.t (* "record" *)
| Remove of Region.t (* "remove" *) | Remove of Region.t (* "remove" *)
| Set of Region.t (* "set" *) | Set of Region.t (* "set" *)
| Skip of Region.t (* "skip" *) | Skip of Region.t (* "skip" *)
| Step of Region.t (* "step" *) | Step of Region.t (* "step" *)
| Then of Region.t (* "then" *) | Then of Region.t (* "then" *)
| To of Region.t (* "to" *) | To of Region.t (* "to" *)
| Type of Region.t (* "type" *) | True of Region.t (* "True" *)
| Var of Region.t (* "var" *) | Type of Region.t (* "type" *)
| While of Region.t (* "while" *) | Unit of Region.t (* "Unit" *)
| With of Region.t (* "with" *) | Var of Region.t (* "var" *)
| While of Region.t (* "while" *)
| With of Region.t (* "with" *)
(* Types *)
(*
| T_address of Region.t (* "address" *)
| T_big_map of Region.t (* "big_map" *)
| T_bool of Region.t (* "bool" *)
| T_bytes of Region.t (* "bytes" *)
| T_contract of Region.t (* "contract" *)
| T_int of Region.t (* "int" *)
| T_key of Region.t (* "key" *)
| T_key_hash of Region.t (* "key_hash" *)
| T_list of Region.t (* "list" *)
| T_map of Region.t (* "map" *)
| T_mutez of Region.t (* "mutez" *)
| T_nat of Region.t (* "nat" *)
| T_operation of Region.t (* "operation" *)
| T_option of Region.t (* "option" *)
| T_set of Region.t (* "set" *)
| T_signature of Region.t (* "signature" *)
| T_string of Region.t (* "string" *)
| T_timestamp of Region.t (* "timestamp" *)
| T_unit of Region.t (* "unit" *)
*)
(* Data constructors *) (* Data constructors *)
| C_False of Region.t (* "False" *)
| C_None of Region.t (* "None" *) | C_None of Region.t (* "None" *)
| C_Some of Region.t (* "Some" *) | C_Some of Region.t (* "Some" *)
| C_True of Region.t (* "True" *)
| C_Unit of Region.t (* "Unit" *)
(* Virtual tokens *) (* Virtual tokens *)
@ -211,6 +188,7 @@ let proj_token = function
| Else region -> region, "Else" | Else region -> region, "Else"
| End region -> region, "End" | End region -> region, "End"
| Fail region -> region, "Fail" | Fail region -> region, "Fail"
| False region -> region, "False"
| For region -> region, "For" | For region -> region, "For"
| From region -> region, "From" | From region -> region, "From"
| Function region -> region, "Function" | Function region -> region, "Function"
@ -225,7 +203,6 @@ let proj_token = function
| Of region -> region, "Of" | Of region -> region, "Of"
| Or region -> region, "Or" | Or region -> region, "Or"
| Patch region -> region, "Patch" | Patch region -> region, "Patch"
| Procedure region -> region, "Procedure"
| Record region -> region, "Record" | Record region -> region, "Record"
| Remove region -> region, "Remove" | Remove region -> region, "Remove"
| Set region -> region, "Set" | Set region -> region, "Set"
@ -233,18 +210,17 @@ let proj_token = function
| Step region -> region, "Step" | Step region -> region, "Step"
| Then region -> region, "Then" | Then region -> region, "Then"
| To region -> region, "To" | To region -> region, "To"
| True region -> region, "True"
| Type region -> region, "Type" | Type region -> region, "Type"
| Unit region -> region, "Unit"
| Var region -> region, "Var" | Var region -> region, "Var"
| While region -> region, "While" | While region -> region, "While"
| With region -> region, "With" | With region -> region, "With"
(* Data *) (* Data *)
| C_False region -> region, "C_False"
| C_None region -> region, "C_None" | C_None region -> region, "C_None"
| C_Some region -> region, "C_Some" | C_Some region -> region, "C_Some"
| C_True region -> region, "C_True"
| C_Unit region -> region, "C_Unit"
(* Virtual tokens *) (* Virtual tokens *)
@ -304,6 +280,7 @@ let to_lexeme = function
| Else _ -> "else" | Else _ -> "else"
| End _ -> "end" | End _ -> "end"
| Fail _ -> "fail" | Fail _ -> "fail"
| False _ -> "False"
| For _ -> "for" | For _ -> "for"
| From _ -> "from" | From _ -> "from"
| Function _ -> "function" | Function _ -> "function"
@ -318,7 +295,6 @@ let to_lexeme = function
| Of _ -> "of" | Of _ -> "of"
| Or _ -> "or" | Or _ -> "or"
| Patch _ -> "patch" | Patch _ -> "patch"
| Procedure _ -> "procedure"
| Record _ -> "record" | Record _ -> "record"
| Remove _ -> "remove" | Remove _ -> "remove"
| Set _ -> "set" | Set _ -> "set"
@ -326,18 +302,17 @@ let to_lexeme = function
| Step _ -> "step" | Step _ -> "step"
| Then _ -> "then" | Then _ -> "then"
| To _ -> "to" | To _ -> "to"
| True _ -> "True"
| Type _ -> "type" | Type _ -> "type"
| Unit _ -> "Unit"
| Var _ -> "var" | Var _ -> "var"
| While _ -> "while" | While _ -> "while"
| With _ -> "with" | With _ -> "with"
(* Data constructors *) (* Data constructors *)
| C_False _ -> "False"
| C_None _ -> "None" | C_None _ -> "None"
| C_Some _ -> "Some" | C_Some _ -> "Some"
| C_True _ -> "True"
| C_Unit _ -> "Unit"
(* Virtual tokens *) (* Virtual tokens *)
@ -368,6 +343,7 @@ let keywords = [
(fun reg -> From reg); (fun reg -> From reg);
(fun reg -> Function reg); (fun reg -> Function reg);
(fun reg -> Fail reg); (fun reg -> Fail reg);
(fun reg -> False reg);
(fun reg -> If reg); (fun reg -> If reg);
(fun reg -> In reg); (fun reg -> In reg);
(fun reg -> Is reg); (fun reg -> Is reg);
@ -376,10 +352,10 @@ let keywords = [
(fun reg -> Mod reg); (fun reg -> Mod reg);
(fun reg -> Nil reg); (fun reg -> Nil reg);
(fun reg -> Not reg); (fun reg -> Not reg);
(fun reg -> C_None reg);
(fun reg -> Of reg); (fun reg -> Of reg);
(fun reg -> Or reg); (fun reg -> Or reg);
(fun reg -> Patch reg); (fun reg -> Patch reg);
(fun reg -> Procedure reg);
(fun reg -> Record reg); (fun reg -> Record reg);
(fun reg -> Remove reg); (fun reg -> Remove reg);
(fun reg -> Set reg); (fun reg -> Set reg);
@ -387,7 +363,9 @@ let keywords = [
(fun reg -> Step reg); (fun reg -> Step reg);
(fun reg -> Then reg); (fun reg -> Then reg);
(fun reg -> To reg); (fun reg -> To reg);
(fun reg -> True reg);
(fun reg -> Type reg); (fun reg -> Type reg);
(fun reg -> Unit reg);
(fun reg -> Var reg); (fun reg -> Var reg);
(fun reg -> While reg); (fun reg -> While reg);
(fun reg -> With reg) (fun reg -> With reg)
@ -398,11 +376,11 @@ let reserved =
empty |> add "args" empty |> add "args"
let constructors = [ let constructors = [
(fun reg -> C_False reg); (fun reg -> False reg);
(fun reg -> C_None reg); (fun reg -> True reg);
(fun reg -> C_Some reg); (fun reg -> Unit reg);
(fun reg -> C_True reg); (fun reg -> C_None reg);
(fun reg -> C_Unit reg) (fun reg -> C_Some reg)
] ]
let add map (key, value) = SMap.add key value map let add map (key, value) = SMap.add key value map
@ -474,11 +452,11 @@ let mk_bytes lexeme region =
type int_err = Non_canonical_zero type int_err = Non_canonical_zero
let mk_int lexeme region = let mk_int lexeme region =
let z = Str.(global_replace (regexp "_") "" lexeme) let z =
|> Z.of_string in Str.(global_replace (regexp "_") "" lexeme) |> Z.of_string
if Z.equal z Z.zero && lexeme <> "0" in if Z.equal z Z.zero && lexeme <> "0"
then Error Non_canonical_zero then Error Non_canonical_zero
else Ok (Int Region.{region; value = lexeme, z}) else Ok (Int Region.{region; value = lexeme,z})
type nat_err = type nat_err =
Invalid_natural Invalid_natural
@ -494,7 +472,7 @@ let mk_nat lexeme region =
Z.of_string in Z.of_string in
if Z.equal z Z.zero && lexeme <> "0n" if Z.equal z Z.zero && lexeme <> "0n"
then Error Non_canonical_zero_nat then Error Non_canonical_zero_nat
else Ok (Nat Region.{region; value = lexeme, z}) else Ok (Nat Region.{region; value = lexeme,z})
) )
let mk_mutez lexeme region = let mk_mutez lexeme region =
@ -533,9 +511,9 @@ let mk_sym lexeme region =
| "*" -> Ok (TIMES region) | "*" -> Ok (TIMES region)
| "/" -> Ok (SLASH region) | "/" -> Ok (SLASH region)
| "<" -> Ok (LT region) | "<" -> Ok (LT region)
| "<=" -> Ok (LE region) | "<=" -> Ok (LE region)
| ">" -> Ok (GT region) | ">" -> Ok (GT region)
| ">=" -> Ok (GE region) | ">=" -> Ok (GE region)
(* Lexemes specific to PascaLIGO *) (* Lexemes specific to PascaLIGO *)
| "=/=" -> Ok (NE region) | "=/=" -> Ok (NE region)
@ -545,20 +523,17 @@ let mk_sym lexeme region =
(* Invalid lexemes *) (* Invalid lexemes *)
| _ -> Error Invalid_symbol | _ -> Error Invalid_symbol
(* Identifiers *) (* Identifiers *)
let mk_ident' lexeme region lexicon = let mk_ident lexeme region =
Lexing.from_string lexeme |> scan_ident region lexicon Lexing.from_string lexeme |> scan_ident region lexicon
let mk_ident lexeme region = mk_ident' lexeme region lexicon
(* Constructors *) (* Constructors *)
let mk_constr' lexeme region lexicon = let mk_constr lexeme region =
Lexing.from_string lexeme |> scan_constr region lexicon Lexing.from_string lexeme |> scan_constr region lexicon
let mk_constr lexeme region = mk_constr' lexeme region lexicon
(* Predicates *) (* Predicates *)
let is_string = function let is_string = function
@ -589,6 +564,7 @@ let is_kwd = function
| Else _ | Else _
| End _ | End _
| Fail _ | Fail _
| False _
| For _ | For _
| From _ | From _
| Function _ | Function _
@ -603,7 +579,6 @@ let is_kwd = function
| Of _ | Of _
| Or _ | Or _
| Patch _ | Patch _
| Procedure _
| Record _ | Record _
| Remove _ | Remove _
| Set _ | Set _
@ -611,7 +586,9 @@ let is_kwd = function
| Step _ | Step _
| Then _ | Then _
| To _ | To _
| True _
| Type _ | Type _
| Unit _
| Var _ | Var _
| While _ | While _
| With _ -> true | With _ -> true
@ -619,11 +596,8 @@ let is_kwd = function
let is_constr = function let is_constr = function
Constr _ Constr _
| C_False _
| C_None _ | C_None _
| C_Some _ | C_Some _ -> true
| C_True _
| C_Unit _ -> true
| _ -> false | _ -> false
let is_sym = function let is_sym = function

6
src/passes/1-parser/pascaligo/ParToken.mly
View File

@ -53,6 +53,7 @@
%token <Region.t> Contains (* "contains" *) %token <Region.t> Contains (* "contains" *)
%token <Region.t> Else (* "else" *) %token <Region.t> Else (* "else" *)
%token <Region.t> End (* "end" *) %token <Region.t> End (* "end" *)
%token <Region.t> False (* "False" *)
%token <Region.t> For (* "for" *) %token <Region.t> For (* "for" *)
%token <Region.t> Function (* "function" *) %token <Region.t> Function (* "function" *)
%token <Region.t> From (* "from" *) %token <Region.t> From (* "from" *)
@ -73,18 +74,17 @@
%token <Region.t> Skip (* "skip" *) %token <Region.t> Skip (* "skip" *)
%token <Region.t> Then (* "then" *) %token <Region.t> Then (* "then" *)
%token <Region.t> To (* "to" *) %token <Region.t> To (* "to" *)
%token <Region.t> True (* "True" *)
%token <Region.t> Type (* "type" *) %token <Region.t> Type (* "type" *)
%token <Region.t> Unit (* "Unit" *)
%token <Region.t> Var (* "var" *) %token <Region.t> Var (* "var" *)
%token <Region.t> While (* "while" *) %token <Region.t> While (* "while" *)
%token <Region.t> With (* "with" *) %token <Region.t> With (* "with" *)
(* Data constructors *) (* Data constructors *)
%token <Region.t> C_False (* "False" *)
%token <Region.t> C_None (* "None" *) %token <Region.t> C_None (* "None" *)
%token <Region.t> C_Some (* "Some" *) %token <Region.t> C_Some (* "Some" *)
%token <Region.t> C_True (* "True" *)
%token <Region.t> C_Unit (* "Unit" *)
(* Virtual tokens *) (* Virtual tokens *)

64
src/passes/1-parser/pascaligo/Parser.mly
View File

@ -161,7 +161,7 @@ function_type:
core_type: core_type:
type_name { type_name {
TAlias $1 TVar $1
} }
| type_name type_tuple { | type_name type_tuple {
let region = cover $1.region $2.region let region = cover $1.region $2.region
@ -200,16 +200,16 @@ type_tuple:
sum_type: sum_type:
option(VBAR) nsepseq(variant,VBAR) { option(VBAR) nsepseq(variant,VBAR) {
let region = nsepseq_to_region (fun x -> x.region) $2 let region = nsepseq_to_region (fun x -> x.region) $2
in {region; value = $2} } in {region; value=$2} }
variant: variant:
Constr Of cartesian { Constr Of cartesian {
let region = cover $1.region (type_expr_to_region $3) let region = cover $1.region (type_expr_to_region $3)
and value = {constr = $1; args = Some ($2, $3)} and value = {constr = $1; arg = Some ($2, $3)}
in {region; value} in {region; value}
} }
| Constr { | Constr {
{region=$1.region; value= {constr=$1; args=None}} } {region=$1.region; value= {constr=$1; arg=None}} }
record_type: record_type:
Record sep_or_term_list(field_decl,SEMI) End { Record sep_or_term_list(field_decl,SEMI) End {
@ -793,7 +793,7 @@ cons_expr:
and stop = expr_to_region $3 in and stop = expr_to_region $3 in
let region = cover start stop let region = cover start stop
and value = {arg1 = $1; op = $2; arg2 = $3} and value = {arg1 = $1; op = $2; arg2 = $3}
in EList (Cons {region; value}) in EList (ECons {region; value})
} }
| add_expr { $1 } | add_expr { $1 }
@ -856,13 +856,13 @@ unary_expr:
core_expr: core_expr:
Int { EArith (Int $1) } Int { EArith (Int $1) }
| Nat { EArith (Nat $1) } | Nat { EArith (Nat $1) }
| Mutez { EArith (Mutez $1) } | Mutez { EArith (Mutez $1) }
| var { EVar $1 } | var { EVar $1 }
| String { EString (String $1) } | String { EString (String $1) }
| Bytes { EBytes $1 } | Bytes { EBytes $1 }
| C_False { ELogic (BoolExpr (False $1)) } | False { ELogic (BoolExpr (False $1)) }
| C_True { ELogic (BoolExpr (True $1)) } | True { ELogic (BoolExpr (True $1)) }
| C_Unit { EUnit $1 } | Unit { EUnit $1 }
| annot_expr { EAnnot $1 } | annot_expr { EAnnot $1 }
| tuple_expr { ETuple $1 } | tuple_expr { ETuple $1 }
| par(expr) { EPar $1 } | par(expr) { EPar $1 }
@ -927,21 +927,21 @@ selection:
record_expr: record_expr:
Record sep_or_term_list(field_assignment,SEMI) End { Record sep_or_term_list(field_assignment,SEMI) End {
let elements, terminator = $2 in let ne_elements, terminator = $2 in
let region = cover $1 $3 let region = cover $1 $3
and value : field_assign AST.reg injection = { and value : field_assign AST.reg ne_injection = {
opening = Kwd $1; opening = Kwd $1;
elements = Some elements; ne_elements;
terminator; terminator;
closing = End $3} closing = End $3}
in {region; value} in {region; value}
} }
| Record LBRACKET sep_or_term_list(field_assignment,SEMI) RBRACKET { | Record LBRACKET sep_or_term_list(field_assignment,SEMI) RBRACKET {
let elements, terminator = $3 in let ne_elements, terminator = $3 in
let region = cover $1 $4 let region = cover $1 $4
and value : field_assign AST.reg injection = { and value : field_assign AST.reg ne_injection = {
opening = KwdBracket ($1,$2); opening = KwdBracket ($1,$2);
elements = Some elements; ne_elements;
terminator; terminator;
closing = RBracket $4} closing = RBracket $4}
in {region; value} } in {region; value} }
@ -971,8 +971,8 @@ arguments:
par(nsepseq(expr,COMMA)) { $1 } par(nsepseq(expr,COMMA)) { $1 }
list_expr: list_expr:
injection(List,expr) { List $1 } injection(List,expr) { EListComp $1 }
| Nil { Nil $1 } | Nil { ENil $1 }
(* Patterns *) (* Patterns *)
@ -980,7 +980,7 @@ pattern:
core_pattern CONS nsepseq(core_pattern,CONS) { core_pattern CONS nsepseq(core_pattern,CONS) {
let value = Utils.nsepseq_cons $1 $2 $3 in let value = Utils.nsepseq_cons $1 $2 $3 in
let region = nsepseq_to_region pattern_to_region value let region = nsepseq_to_region pattern_to_region value
in PCons {region; value}} in PList (PCons {region; value}) }
| core_pattern { $1 } | core_pattern { $1 }
core_pattern: core_pattern:
@ -990,21 +990,14 @@ core_pattern:
| Nat { PNat $1 } | Nat { PNat $1 }
| Bytes { PBytes $1 } | Bytes { PBytes $1 }
| String { PString $1 } | String { PString $1 }
| C_Unit { PUnit $1 }
| C_False { PFalse $1 }
| C_True { PTrue $1 }
| C_None { PNone $1 }
| list_pattern { PList $1 } | list_pattern { PList $1 }
| tuple_pattern { PTuple $1 } | tuple_pattern { PTuple $1 }
| constr_pattern { PConstr $1 } | constr_pattern { PConstr $1 }
| C_Some par(core_pattern) {
let region = cover $1 $2.region
in PSome {region; value = $1,$2}}
list_pattern: list_pattern:
injection(List,core_pattern) { Sugar $1 } injection(List,core_pattern) { PListComp $1 }
| Nil { PNil $1 } | Nil { PNil $1 }
| par(cons_pattern) { Raw $1 } | par(cons_pattern) { PParCons $1 }
cons_pattern: cons_pattern:
core_pattern CONS pattern { $1,$2,$3 } core_pattern CONS pattern { $1,$2,$3 }
@ -1013,10 +1006,17 @@ tuple_pattern:
par(nsepseq(core_pattern,COMMA)) { $1 } par(nsepseq(core_pattern,COMMA)) { $1 }
constr_pattern: constr_pattern:
Constr tuple_pattern { Unit { PUnit $1 }
| False { PFalse $1 }
| True { PTrue $1 }
| C_None { PNone $1 }
| C_Some par(core_pattern) {
let region = cover $1 $2.region
in PSomeApp {region; value = $1,$2}
}
| Constr tuple_pattern {
let region = cover $1.region $2.region let region = cover $1.region $2.region
in {region; value = $1, Some $2} in PConstrApp {region; value = $1, Some $2}
} }
| Constr { | Constr {
{region=$1.region; value = $1, None} PConstrApp {region=$1.region; value = $1, None} }
}

583
src/passes/1-parser/pascaligo/ParserLog.ml
View File

@ -107,15 +107,15 @@ and print_type_expr buffer = function
| TApp type_app -> print_type_app buffer type_app | TApp type_app -> print_type_app buffer type_app
| TFun type_fun -> print_type_fun buffer type_fun | TFun type_fun -> print_type_fun buffer type_fun
| TPar par_type -> print_par_type buffer par_type | TPar par_type -> print_par_type buffer par_type
| TAlias type_alias -> print_var buffer type_alias | TVar type_var -> print_var buffer type_var
and print_cartesian buffer {value; _} = and print_cartesian buffer {value; _} =
print_nsepseq buffer "*" print_type_expr value print_nsepseq buffer "*" print_type_expr value
and print_variant buffer ({value; _}: variant reg) = and print_variant buffer ({value; _}: variant reg) =
let {constr; args} = value in let {constr; arg} = value in
print_constr buffer constr; print_constr buffer constr;
match args with match arg with
None -> () None -> ()
| Some (kwd_of, t_expr) -> | Some (kwd_of, t_expr) ->
print_token buffer kwd_of "of"; print_token buffer kwd_of "of";
@ -538,12 +538,12 @@ and print_string_expr buffer = function
print_string buffer s print_string buffer s
and print_list_expr buffer = function and print_list_expr buffer = function
Cons {value = {arg1; op; arg2}; _} -> ECons {value = {arg1; op; arg2}; _} ->
print_expr buffer arg1; print_expr buffer arg1;
print_token buffer op "#"; print_token buffer op "#";
print_expr buffer arg2 print_expr buffer arg2
| List e -> print_injection buffer "list" print_expr e | EListComp e -> print_injection buffer "list" print_expr e
| Nil e -> print_nil buffer e | ENil e -> print_nil buffer e
and print_constr_expr buffer = function and print_constr_expr buffer = function
SomeApp e -> print_some_app buffer e SomeApp e -> print_some_app buffer e
@ -551,7 +551,7 @@ and print_constr_expr buffer = function
| ConstrApp e -> print_constr_app buffer e | ConstrApp e -> print_constr_app buffer e
and print_record_expr buffer e = and print_record_expr buffer e =
print_injection buffer "record" print_field_assign e print_ne_injection buffer "record" print_field_assign e
and print_field_assign buffer {value; _} = and print_field_assign buffer {value; _} =
let {field_name; equal; field_expr} = value in let {field_name; equal; field_expr} = value in
@ -666,7 +666,7 @@ and print_constr_app buffer {value; _} =
print_constr buffer constr; print_constr buffer constr;
match arguments with match arguments with
None -> () None -> ()
| Some args -> print_tuple_expr buffer args | Some arg -> print_tuple_expr buffer arg
and print_some_app buffer {value; _} = and print_some_app buffer {value; _} =
let c_Some, arguments = value in let c_Some, arguments = value in
@ -680,28 +680,28 @@ and print_par_expr buffer {value; _} =
print_token buffer rpar ")" print_token buffer rpar ")"
and print_pattern buffer = function and print_pattern buffer = function
PCons {value; _} -> print_nsepseq buffer "#" print_pattern value PVar var -> print_var buffer var
| PVar var -> print_var buffer var
| PWild wild -> print_token buffer wild "_" | PWild wild -> print_token buffer wild "_"
| PInt i -> print_int buffer i | PInt i -> print_int buffer i
| PNat n -> print_nat buffer n | PNat n -> print_nat buffer n
| PBytes b -> print_bytes buffer b | PBytes b -> print_bytes buffer b
| PString s -> print_string buffer s | PString s -> print_string buffer s
| PUnit region -> print_token buffer region "Unit"
| PFalse region -> print_token buffer region "False"
| PTrue region -> print_token buffer region "True"
| PNone region -> print_token buffer region "None"
| PSome psome -> print_psome buffer psome
| PList pattern -> print_list_pattern buffer pattern | PList pattern -> print_list_pattern buffer pattern
| PTuple ptuple -> print_ptuple buffer ptuple | PTuple ptuple -> print_ptuple buffer ptuple
| PConstr pattern -> print_constr_pattern buffer pattern | PConstr pattern -> print_constr_pattern buffer pattern
and print_constr_pattern buffer {value; _} = and print_constr_pattern buffer = function
let (constr, args) = value in PUnit region -> print_token buffer region "Unit"
print_constr buffer constr; | PFalse region -> print_token buffer region "False"
match args with | PTrue region -> print_token buffer region "True"
None -> () | PNone region -> print_token buffer region "None"
| Some tuple -> print_ptuple buffer tuple | PSomeApp psome -> print_psome buffer psome
| PConstrApp {value; _} ->
let constr, arg = value in
print_constr buffer constr;
match arg with
None -> ()
| Some tuple -> print_ptuple buffer tuple
and print_psome buffer {value; _} = and print_psome buffer {value; _} =
let c_Some, patterns = value in let c_Some, patterns = value in
@ -715,14 +715,16 @@ and print_patterns buffer {value; _} =
print_token buffer rpar ")" print_token buffer rpar ")"
and print_list_pattern buffer = function and print_list_pattern buffer = function
Sugar sugar -> PListComp comp ->
print_injection buffer "list" print_pattern sugar print_injection buffer "list" print_pattern comp
| PNil kwd_nil -> | PNil kwd_nil ->
print_token buffer kwd_nil "nil" print_token buffer kwd_nil "nil"
| Raw raw -> | PParCons cons ->
print_raw buffer raw print_par_cons buffer cons
| PCons {value; _} ->
print_nsepseq buffer "#" print_pattern value
and print_raw buffer {value; _} = and print_par_cons buffer {value; _} =
let {lpar; inside; rpar} = value in let {lpar; inside; rpar} = value in
let head, cons, tail = inside in let head, cons, tail = inside in
print_token buffer lpar "("; print_token buffer lpar "(";
@ -755,17 +757,27 @@ let instruction_to_string = to_string print_instruction
(* Pretty-printing the AST *) (* Pretty-printing the AST *)
(* The function [mk_pad] updates the current padding, which is
comprised of two components: the padding to reach the new node
(space before reaching a subtree, then a vertical bar for it) and
the padding for the new node itself (Is it the last child of its
parent?). *)
let mk_pad len rank pc = let mk_pad len rank pc =
pc ^ (if rank = len-1 then "`-- " else "|-- "), pc ^ (if rank = len-1 then "`-- " else "|-- "),
pc ^ (if rank = len-1 then " " else "| ") pc ^ (if rank = len-1 then " " else "| ")
let pp_ident buffer ~pad:(pd,_) name = let pp_ident buffer ~pad:(pd,_) Region.{value=name; region} =
let node = sprintf "%s%s (%s)\n" pd name (region#compact `Byte)
in Buffer.add_string buffer node
let pp_node buffer ~pad:(pd,_) name =
let node = sprintf "%s%s\n" pd name let node = sprintf "%s%s\n" pd name
in Buffer.add_string buffer node in Buffer.add_string buffer node
let pp_string buffer = pp_ident buffer let pp_string buffer = pp_ident buffer
let pp_node buffer = pp_ident buffer let pp_loc_node buffer ~pad name region =
pp_ident buffer ~pad Region.{value=name; region}
let rec pp_ast buffer ~pad:(_,pc as pad) {decl; _} = let rec pp_ast buffer ~pad:(_,pc as pad) {decl; _} =
let apply len rank = let apply len rank =
@ -776,52 +788,52 @@ let rec pp_ast buffer ~pad:(_,pc as pad) {decl; _} =
List.iteri (List.length decls |> apply) decls List.iteri (List.length decls |> apply) decls
and pp_declaration buffer ~pad:(_,pc as pad) = function and pp_declaration buffer ~pad:(_,pc as pad) = function
TypeDecl {value; _} -> TypeDecl {value; region} ->
pp_node buffer ~pad "TypeDecl"; pp_loc_node buffer ~pad "TypeDecl" region;
pp_ident buffer ~pad:(mk_pad 2 0 pc) value.name.value; pp_ident buffer ~pad:(mk_pad 2 0 pc) value.name;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.type_expr pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.type_expr
| ConstDecl {value; _} -> | ConstDecl {value; region} ->
pp_node buffer ~pad "ConstDecl"; pp_loc_node buffer ~pad "ConstDecl" region;
pp_const_decl buffer ~pad value pp_const_decl buffer ~pad value
| FunDecl {value; _} -> | FunDecl {value; region} ->
pp_node buffer ~pad "FunDecl"; pp_loc_node buffer ~pad "FunDecl" region;
pp_fun_decl buffer ~pad value pp_fun_decl buffer ~pad value
and pp_const_decl buffer ~pad:(_,pc) decl = and pp_const_decl buffer ~pad:(_,pc) decl =
pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name.value; pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name;
pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.const_type; pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.const_type;
pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init
and pp_type_expr buffer ~pad:(_,pc as pad) = function and pp_type_expr buffer ~pad:(_,pc as pad) = function
TProd cartesian -> TProd cartesian ->
pp_node buffer ~pad "TProd"; pp_loc_node buffer ~pad "TProd" cartesian.region;
pp_cartesian buffer ~pad cartesian pp_cartesian buffer ~pad cartesian
| TAlias {value; _} -> | TVar v ->
pp_node buffer ~pad "TAlias"; pp_node buffer ~pad "TVar";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value pp_ident buffer ~pad:(mk_pad 1 0 pc) v
| TPar {value; _} -> | TPar {value; region} ->
pp_node buffer ~pad "TPar"; pp_loc_node buffer ~pad "TPar" region;
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) value.inside pp_type_expr buffer ~pad:(mk_pad 1 0 pc) value.inside
| TApp {value=name,tuple; _} -> | TApp {value=name,tuple; region} ->
pp_node buffer ~pad "TApp"; pp_loc_node buffer ~pad "TApp" region;
pp_ident buffer ~pad:(mk_pad 1 0 pc) name.value; pp_ident buffer ~pad:(mk_pad 1 0 pc) name;
pp_type_tuple buffer ~pad:(mk_pad 2 1 pc) tuple pp_type_tuple buffer ~pad:(mk_pad 2 1 pc) tuple
| TFun {value; _} -> | TFun {value; region} ->
pp_node buffer ~pad "TFun"; pp_loc_node buffer ~pad "TFun" region;
let apply len rank = let apply len rank =
let pad = mk_pad len rank pc in let pad = mk_pad len rank pc in
pp_type_expr buffer ~pad in pp_type_expr buffer ~pad in
let domain, _, range = value in let domain, _, range = value in
List.iteri (apply 2) [domain; range] List.iteri (apply 2) [domain; range]
| TSum {value; _} -> | TSum {value; region} ->
pp_node buffer ~pad "TSum"; pp_loc_node buffer ~pad "TSum" region;
let apply len rank variant = let apply len rank variant =
let pad = mk_pad len rank pc in let pad = mk_pad len rank pc in
pp_variant buffer ~pad variant.value in pp_variant buffer ~pad variant.value in
let variants = Utils.nsepseq_to_list value in let variants = Utils.nsepseq_to_list value in
List.iteri (List.length variants |> apply) variants List.iteri (List.length variants |> apply) variants
| TRecord {value; _} -> | TRecord {value; region} ->
pp_node buffer ~pad "TRecord"; pp_loc_node buffer ~pad "TRecord" region;
let apply len rank field_decl = let apply len rank field_decl =
pp_field_decl buffer ~pad:(mk_pad len rank pc) pp_field_decl buffer ~pad:(mk_pad len rank pc)
field_decl.value in field_decl.value in
@ -834,15 +846,15 @@ and pp_cartesian buffer ~pad:(_,pc) {value; _} =
let components = Utils.nsepseq_to_list value let components = Utils.nsepseq_to_list value
in List.iteri (List.length components |> apply) components in List.iteri (List.length components |> apply) components
and pp_variant buffer ~pad:(_,pc as pad) {constr; args} = and pp_variant buffer ~pad:(_,pc as pad) {constr; arg} =
pp_node buffer ~pad constr.value; pp_ident buffer ~pad constr;
match args with match arg with
None -> () None -> ()
| Some (_,c) -> | Some (_,c) ->
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) c pp_type_expr buffer ~pad:(mk_pad 1 0 pc) c
and pp_field_decl buffer ~pad:(_,pc as pad) decl = and pp_field_decl buffer ~pad:(_,pc as pad) decl =
pp_node buffer ~pad decl.field_name.value; pp_ident buffer ~pad decl.field_name;
pp_type_expr buffer ~pad:(mk_pad 1 0 pc) decl.field_type pp_type_expr buffer ~pad:(mk_pad 1 0 pc) decl.field_type
and pp_type_tuple buffer ~pad:(_,pc) {value; _} = and pp_type_tuple buffer ~pad:(_,pc) {value; _} =
@ -856,7 +868,7 @@ and pp_fun_decl buffer ~pad:(_,pc) decl =
if decl.local_decls = [] then 5 else 6 in if decl.local_decls = [] then 5 else 6 in
let () = let () =
let pad = mk_pad fields 0 pc in let pad = mk_pad fields 0 pc in
pp_ident buffer ~pad decl.name.value in pp_ident buffer ~pad decl.name in
let () = let () =
let pad = mk_pad fields 1 pc in let pad = mk_pad fields 1 pc in
pp_node buffer ~pad "<parameters>"; pp_node buffer ~pad "<parameters>";
@ -875,8 +887,8 @@ and pp_fun_decl buffer ~pad:(_,pc) decl =
pp_node buffer ~pad "<block>"; pp_node buffer ~pad "<block>";
let statements = let statements =
match decl.block with match decl.block with
| Some block -> block.value.statements Some block -> block.value.statements
| None -> Instr (Skip Region.ghost), [] in | None -> Instr (Skip Region.ghost), [] in
pp_statements buffer ~pad statements in pp_statements buffer ~pad statements in
let () = let () =
let _, pc as pad = mk_pad fields (fields - 1) pc in let _, pc as pad = mk_pad fields (fields - 1) pc in
@ -892,13 +904,13 @@ and pp_parameters buffer ~pad:(_,pc) {value; _} =
in List.iteri (apply arity) params in List.iteri (apply arity) params
and pp_param_decl buffer ~pad:(_,pc as pad) = function and pp_param_decl buffer ~pad:(_,pc as pad) = function
ParamConst {value; _} -> ParamConst {value; region} ->
pp_node buffer ~pad "ParamConst"; pp_loc_node buffer ~pad "ParamConst" region;
pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var.value; pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type
| ParamVar {value; _} -> | ParamVar {value; region} ->
pp_node buffer ~pad "ParamVar"; pp_loc_node buffer ~pad "ParamVar" region;
pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var.value; pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type
and pp_statements buffer ~pad:(_,pc) statements = and pp_statements buffer ~pad:(_,pc) statements =
@ -917,37 +929,37 @@ and pp_statement buffer ~pad:(_,pc as pad) = function
pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data_decl pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data_decl
and pp_instruction buffer ~pad:(_,pc as pad) = function and pp_instruction buffer ~pad:(_,pc as pad) = function
Cond {value; _} -> Cond {value; region} ->
pp_node buffer ~pad "Cond"; pp_loc_node buffer ~pad "Cond" region;
pp_conditional buffer ~pad value pp_conditional buffer ~pad value
| CaseInstr {value; _} -> | CaseInstr {value; region} ->
pp_node buffer ~pad "CaseInstr"; pp_loc_node buffer ~pad "CaseInstr" region;
pp_case pp_if_clause buffer ~pad value pp_case pp_if_clause buffer ~pad value
| Assign {value; _} -> | Assign {value; region} ->
pp_node buffer ~pad "Assign"; pp_loc_node buffer ~pad "Assign" region;
pp_assignment buffer ~pad value pp_assignment buffer ~pad value
| Loop loop -> | Loop loop ->
pp_node buffer ~pad "Loop"; pp_node buffer ~pad "Loop";
pp_loop buffer ~pad:(mk_pad 1 0 pc) loop pp_loop buffer ~pad:(mk_pad 1 0 pc) loop
| ProcCall {value; _} -> | ProcCall {value; region} ->
pp_node buffer ~pad "ProcCall"; pp_loc_node buffer ~pad "ProcCall" region;
pp_fun_call buffer ~pad value pp_fun_call buffer ~pad value
| Skip _ -> | Skip region ->
pp_node buffer ~pad "Skip" pp_loc_node buffer ~pad "Skip" region
| RecordPatch {value; _} -> | RecordPatch {value; region} ->
pp_node buffer ~pad "RecordPatch"; pp_loc_node buffer ~pad "RecordPatch" region;
pp_record_patch buffer ~pad value pp_record_patch buffer ~pad value
| MapPatch {value; _} -> | MapPatch {value; region} ->
pp_node buffer ~pad "MapPatch"; pp_loc_node buffer ~pad "MapPatch" region;
pp_map_patch buffer ~pad value pp_map_patch buffer ~pad value
| SetPatch {value; _} -> | SetPatch {value; region} ->
pp_node buffer ~pad "SetPatch"; pp_loc_node buffer ~pad "SetPatch" region;
pp_set_patch buffer ~pad value pp_set_patch buffer ~pad value
| MapRemove {value; _} -> | MapRemove {value; region} ->
pp_node buffer ~pad "MapRemove"; pp_loc_node buffer ~pad "MapRemove" region;
pp_map_remove buffer ~pad value pp_map_remove buffer ~pad value
| SetRemove {value; _} -> | SetRemove {value; region} ->
pp_node buffer ~pad "SetRemove"; pp_loc_node buffer ~pad "SetRemove" region;
pp_set_remove buffer ~pad value pp_set_remove buffer ~pad value
and pp_cond_expr buffer ~pad:(_,pc) (cond: cond_expr) = and pp_cond_expr buffer ~pad:(_,pc) (cond: cond_expr) =
@ -989,13 +1001,12 @@ and pp_if_clause buffer ~pad:(_,pc as pad) = function
pp_clause_block buffer ~pad:(mk_pad 1 0 pc) block pp_clause_block buffer ~pad:(mk_pad 1 0 pc) block
and pp_clause_block buffer ~pad = function and pp_clause_block buffer ~pad = function
LongBlock {value; _} -> LongBlock {value; region} ->
pp_node buffer ~pad "LongBlock"; pp_loc_node buffer ~pad "LongBlock" region;
pp_statements buffer ~pad value.statements pp_statements buffer ~pad value.statements
| ShortBlock {value; _} -> | ShortBlock {value; region} ->
pp_node buffer ~pad "ShortBlock"; pp_loc_node buffer ~pad "ShortBlock" region;
let statements = fst value.inside in pp_statements buffer ~pad (fst value.inside)
pp_statements buffer ~pad statements
and pp_case : and pp_case :
'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit)
@ -1018,77 +1029,81 @@ and pp_case_clause :
printer buffer ~pad:(mk_pad 2 1 pc) clause.rhs printer buffer ~pad:(mk_pad 2 1 pc) clause.rhs
and pp_pattern buffer ~pad:(_,pc as pad) = function and pp_pattern buffer ~pad:(_,pc as pad) = function
PNone _ -> PWild region ->
pp_node buffer ~pad "PNone" pp_loc_node buffer ~pad "PWild" region
| PSome {value=_,{value=par; _}; _} -> | PConstr pattern ->
pp_node buffer ~pad "PSome";
pp_pattern buffer ~pad:(mk_pad 1 0 pc) par.inside
| PWild _ ->
pp_node buffer ~pad "PWild"
| PConstr {value; _} ->
pp_node buffer ~pad "PConstr"; pp_node buffer ~pad "PConstr";
pp_constr_pattern buffer ~pad:(mk_pad 1 0 pc) value pp_constr_pattern buffer ~pad:(mk_pad 1 0 pc) pattern
| PCons {value; _} -> | PVar v ->
pp_node buffer ~pad "PVar";
pp_ident buffer ~pad:(mk_pad 1 0 pc) v
| PInt n ->
pp_node buffer ~pad "PInt";
pp_int buffer ~pad n
| PNat n ->
pp_node buffer ~pad "PNat";
pp_int buffer ~pad n
| PBytes b ->
pp_node buffer ~pad "PBytes";
pp_bytes buffer ~pad b
| PString s ->
pp_node buffer ~pad "PString";
pp_ident buffer ~pad:(mk_pad 1 0 pc) s
| PList plist ->
pp_node buffer ~pad "PList";
pp_list_pattern buffer ~pad:(mk_pad 1 0 pc) plist
| PTuple {value; region} ->
pp_loc_node buffer ~pad "PTuple" region;
pp_tuple_pattern buffer ~pad:(mk_pad 1 0 pc) value
and pp_bytes buffer ~pad:(_,pc) {value=lexeme,hex; region} =
pp_loc_node buffer ~pad:(mk_pad 2 0 pc) lexeme region;
pp_node buffer ~pad:(mk_pad 2 1 pc) (Hex.to_string hex)
and pp_int buffer ~pad:(_,pc) {value=lexeme,z; region} =
pp_loc_node buffer ~pad:(mk_pad 2 0 pc) lexeme region;
pp_node buffer ~pad:(mk_pad 2 1 pc) (Z.to_string z)
and pp_constr_pattern buffer ~pad:(_,pc as pad) = function
PNone region ->
pp_loc_node buffer ~pad "PNone" region
| PSomeApp {value=_,{value=par; _}; region} ->
pp_loc_node buffer ~pad "PSomeApp" region;
pp_pattern buffer ~pad:(mk_pad 1 0 pc) par.inside
| PUnit region ->
pp_loc_node buffer ~pad "PUnit" region
| PFalse region ->
pp_loc_node buffer ~pad "PFalse" region
| PTrue region ->
pp_loc_node buffer ~pad "PTrue" region
| PConstrApp {value; region} ->
pp_loc_node buffer ~pad "PConstrApp" region;
pp_constr_app_pattern buffer ~pad:(mk_pad 1 0 pc) value
and pp_constr_app_pattern buffer ~pad (constr, pat_opt) =
pp_ident buffer ~pad constr;
match pat_opt with
None -> ()
| Some {value; _} -> pp_tuple_pattern buffer ~pad value
and pp_list_pattern buffer ~pad:(_,pc as pad) = function
PListComp {value; region} ->
pp_loc_node buffer ~pad "PListComp" region;
pp_injection pp_pattern buffer ~pad:(mk_pad 1 0 pc) value
| PNil region ->
pp_loc_node buffer ~pad "PNil" region
| PParCons {value; region} ->
pp_loc_node buffer ~pad "PParCons" region;
pp_bin_cons buffer ~pad:(mk_pad 1 0 pc) value.inside
| PCons {value; region} ->
let patterns = Utils.nsepseq_to_list value in let patterns = Utils.nsepseq_to_list value in
let length = List.length patterns in let length = List.length patterns in
let apply len rank = let apply len rank =
pp_pattern buffer ~pad:(mk_pad len rank pc) in pp_pattern buffer ~pad:(mk_pad len rank pc) in
pp_node buffer ~pad "PCons"; pp_loc_node buffer ~pad "PCons" region;
List.iteri (apply length) patterns List.iteri (apply length) patterns
| PVar {value; _} ->
pp_node buffer ~pad "PVar";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value
| PInt {value; _} ->
pp_node buffer ~pad "PInt";
pp_int buffer ~pad value
| PNat {value; _} ->
pp_node buffer ~pad "PNat";
pp_int buffer ~pad value
| PBytes {value; _} ->
pp_node buffer ~pad "PBytes";
pp_bytes buffer ~pad value
| PString {value; _} ->
pp_node buffer ~pad "PString";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value
| PUnit _ ->
pp_node buffer ~pad "PUnit"
| PFalse _ ->
pp_node buffer ~pad "PFalse"
| PTrue _ ->
pp_node buffer ~pad "PTrue"
| PList plist ->
pp_node buffer ~pad "PList";
pp_plist buffer ~pad:(mk_pad 1 0 pc) plist
| PTuple {value; _} ->
pp_node buffer ~pad "PTuple";
pp_tuple_pattern buffer ~pad:(mk_pad 1 0 pc) value
and pp_bytes buffer ~pad:(_,pc) (lexeme, hex) = and pp_bin_cons buffer ~pad:(_,pc) (head, _, tail) =
pp_string buffer ~pad:(mk_pad 2 0 pc) lexeme;
pp_string buffer ~pad:(mk_pad 2 1 pc) (Hex.to_string hex)
and pp_int buffer ~pad:(_,pc) (lexeme, z) =
pp_string buffer ~pad:(mk_pad 2 0 pc) lexeme;
pp_string buffer ~pad:(mk_pad 2 1 pc) (Z.to_string z)
and pp_constr_pattern buffer ~pad = function
{value; _}, None ->
pp_ident buffer ~pad value
| {value=id; _}, Some {value=ptuple; _} ->
pp_ident buffer ~pad id;
pp_tuple_pattern buffer ~pad ptuple
and pp_plist buffer ~pad:(_,pc as pad) = function
Sugar {value; _} ->
pp_node buffer ~pad "Sugar";
pp_injection pp_pattern buffer ~pad:(mk_pad 1 0 pc) value
| PNil _ ->
pp_node buffer ~pad "PNil"
| Raw {value; _} ->
pp_node buffer ~pad "Raw";
pp_raw buffer ~pad:(mk_pad 1 0 pc) value.inside
and pp_raw buffer ~pad:(_,pc) (head, _, tail) =
pp_pattern buffer ~pad:(mk_pad 2 0 pc) head; pp_pattern buffer ~pad:(mk_pad 2 0 pc) head;
pp_pattern buffer ~pad:(mk_pad 2 1 pc) tail pp_pattern buffer ~pad:(mk_pad 2 1 pc) tail
@ -1118,23 +1133,23 @@ and pp_tuple_pattern buffer ~pad:(_,pc) tuple =
in List.iteri (apply length) patterns in List.iteri (apply length) patterns
and pp_assignment buffer ~pad:(_,pc) asgn = and pp_assignment buffer ~pad:(_,pc) asgn =
pp_lhs buffer ~pad:(mk_pad 2 0 pc) asgn.lhs; pp_lhs buffer ~pad:(mk_pad 2 0 pc) asgn.lhs;
pp_expr buffer ~pad:(mk_pad 2 1 pc) asgn.rhs pp_expr buffer ~pad:(mk_pad 2 1 pc) asgn.rhs
and pp_lhs buffer ~pad:(_,pc as pad) = function and pp_lhs buffer ~pad:(_,pc as pad) = function
Path path -> Path path ->
pp_node buffer ~pad "Path"; pp_node buffer ~pad "Path";
pp_path buffer ~pad:(mk_pad 1 0 pc) path pp_path buffer ~pad:(mk_pad 1 0 pc) path
| MapPath {value; _} -> | MapPath {value; region} ->
pp_node buffer ~pad "MapPath"; pp_loc_node buffer ~pad "MapPath" region;
pp_map_lookup buffer ~pad value pp_map_lookup buffer ~pad value
and pp_path buffer ~pad:(_,pc as pad) = function and pp_path buffer ~pad:(_,pc as pad) = function
Name {value; _} -> Name name ->
pp_node buffer ~pad "Name"; pp_node buffer ~pad "Name";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value pp_ident buffer ~pad:(mk_pad 1 0 pc) name
| Path {value; _} -> | Path {value; region} ->
pp_node buffer ~pad "Path"; pp_loc_node buffer ~pad "Path" region;
pp_projection buffer ~pad value pp_projection buffer ~pad value
and pp_projection buffer ~pad:(_,pc) proj = and pp_projection buffer ~pad:(_,pc) proj =
@ -1142,16 +1157,16 @@ and pp_projection buffer ~pad:(_,pc) proj =
let len = List.length selections in let len = List.length selections in
let apply len rank = let apply len rank =
pp_selection buffer ~pad:(mk_pad len rank pc) in pp_selection buffer ~pad:(mk_pad len rank pc) in
pp_ident buffer ~pad:(mk_pad (1+len) 0 pc) proj.struct_name.value; pp_ident buffer ~pad:(mk_pad (1+len) 0 pc) proj.struct_name;
List.iteri (apply len) selections List.iteri (apply len) selections
and pp_selection buffer ~pad:(_,pc as pad) = function and pp_selection buffer ~pad:(_,pc as pad) = function
FieldName {value; _} -> FieldName name ->
pp_node buffer ~pad "FieldName"; pp_node buffer ~pad "FieldName";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value pp_ident buffer ~pad:(mk_pad 1 0 pc) name
| Component {value; _} -> | Component comp ->
pp_node buffer ~pad "Component"; pp_node buffer ~pad "Component";
pp_int buffer ~pad value pp_int buffer ~pad comp
and pp_map_lookup buffer ~pad:(_,pc) lookup = and pp_map_lookup buffer ~pad:(_,pc) lookup =
pp_path buffer ~pad:(mk_pad 2 0 pc) lookup.path; pp_path buffer ~pad:(mk_pad 2 0 pc) lookup.path;
@ -1175,11 +1190,11 @@ and pp_loop buffer ~pad:(_,pc as pad) = function
pp_for_loop buffer ~pad:(mk_pad 1 0 pc) for_loop pp_for_loop buffer ~pad:(mk_pad 1 0 pc) for_loop
and pp_for_loop buffer ~pad = function and pp_for_loop buffer ~pad = function
ForInt {value; _} -> ForInt {value; region} ->
pp_node buffer ~pad "ForInt"; pp_loc_node buffer ~pad "ForInt" region;
pp_for_int buffer ~pad value pp_for_int buffer ~pad value
| ForCollect {value; _} -> | ForCollect {value; region} ->
pp_node buffer ~pad "ForCollect"; pp_loc_node buffer ~pad "ForCollect" region;
pp_for_collect buffer ~pad value pp_for_collect buffer ~pad value
and pp_for_int buffer ~pad:(_,pc) for_int = and pp_for_int buffer ~pad:(_,pc) for_int =
@ -1200,7 +1215,7 @@ and pp_for_int buffer ~pad:(_,pc) for_int =
and pp_var_assign buffer ~pad:(_,pc) asgn = and pp_var_assign buffer ~pad:(_,pc) asgn =
let pad = mk_pad 2 0 pc in let pad = mk_pad 2 0 pc in
pp_ident buffer ~pad asgn.name.value; pp_ident buffer ~pad asgn.name;
let pad = mk_pad 2 1 pc in let pad = mk_pad 2 1 pc in
pp_expr buffer ~pad asgn.expr pp_expr buffer ~pad asgn.expr
@ -1209,7 +1224,7 @@ and pp_for_collect buffer ~pad:(_,pc) collect =
let pad = mk_pad 4 0 pc in let pad = mk_pad 4 0 pc in
match collect.bind_to with match collect.bind_to with
None -> None ->
pp_ident buffer ~pad collect.var.value pp_ident buffer ~pad collect.var
| Some (_, var) -> | Some (_, var) ->
pp_var_binding buffer ~pad (collect.var, var) in pp_var_binding buffer ~pad (collect.var, var) in
let () = let () =
@ -1229,22 +1244,22 @@ and pp_for_collect buffer ~pad:(_,pc) collect =
in () in ()
and pp_collection buffer ~pad = function and pp_collection buffer ~pad = function
Map _ -> pp_string buffer ~pad "map" Map region -> pp_loc_node buffer ~pad "map" region
| Set _ -> pp_string buffer ~pad "set" | Set region -> pp_loc_node buffer ~pad "set" region
| List _ -> pp_string buffer ~pad "list" | List region -> pp_loc_node buffer ~pad "list" region
and pp_var_binding buffer ~pad:(_,pc as pad) (source, image) = and pp_var_binding buffer ~pad:(_,pc as pad) (source, image) =
pp_node buffer ~pad "<binding>"; pp_node buffer ~pad "<binding>";
pp_ident buffer ~pad:(mk_pad 2 0 pc) source.value; pp_ident buffer ~pad:(mk_pad 2 0 pc) source;
pp_ident buffer ~pad:(mk_pad 2 1 pc) image.value pp_ident buffer ~pad:(mk_pad 2 1 pc) image
and pp_fun_call buffer ~pad:(_,pc) (name, args) = and pp_fun_call buffer ~pad:(_,pc) (name, args) =
let args = Utils.nsepseq_to_list args.value.inside in let args = Utils.nsepseq_to_list args.value.inside in
let arity = List.length args in let arity = List.length args in
let apply len rank = let apply len rank =
pp_expr buffer ~pad:(mk_pad len rank pc) pp_expr buffer ~pad:(mk_pad len rank pc)
in pp_ident buffer ~pad:(mk_pad (1+arity) 0 pc) name.value; in pp_ident buffer ~pad:(mk_pad (1+arity) 0 pc) name;
List.iteri (apply arity) args List.iteri (apply arity) args
and pp_record_patch buffer ~pad:(_,pc as pad) patch = and pp_record_patch buffer ~pad:(_,pc as pad) patch =
pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path; pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path;
@ -1253,7 +1268,7 @@ and pp_record_patch buffer ~pad:(_,pc as pad) patch =
and pp_field_assign buffer ~pad:(_,pc as pad) {value; _} = and pp_field_assign buffer ~pad:(_,pc as pad) {value; _} =
pp_node buffer ~pad "<field assignment>"; pp_node buffer ~pad "<field assignment>";
pp_ident buffer ~pad:(mk_pad 2 0 pc) value.field_name.value; pp_ident buffer ~pad:(mk_pad 2 0 pc) value.field_name;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.field_expr pp_expr buffer ~pad:(mk_pad 2 1 pc) value.field_expr
and pp_map_patch buffer ~pad:(_,pc as pad) patch = and pp_map_patch buffer ~pad:(_,pc as pad) patch =
@ -1285,35 +1300,35 @@ and pp_local_decls buffer ~pad:(_,pc) decls =
in List.iteri (List.length decls |> apply) decls in List.iteri (List.length decls |> apply) decls
and pp_local_decl buffer ~pad:(_,pc as pad) = function and pp_local_decl buffer ~pad:(_,pc as pad) = function
LocalFun {value; _} -> LocalFun {value; region} ->
pp_node buffer ~pad "LocalFun"; pp_loc_node buffer ~pad "LocalFun" region;
pp_fun_decl buffer ~pad value pp_fun_decl buffer ~pad value
| LocalData data -> | LocalData data ->
pp_node buffer ~pad "LocalData"; pp_node buffer ~pad "LocalData";
pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data
and pp_data_decl buffer ~pad = function and pp_data_decl buffer ~pad = function
LocalConst {value; _} -> LocalConst {value; region} ->
pp_node buffer ~pad "LocalConst"; pp_loc_node buffer ~pad "LocalConst" region;
pp_const_decl buffer ~pad value pp_const_decl buffer ~pad value
| LocalVar {value; _} -> | LocalVar {value; region} ->
pp_node buffer ~pad "LocalVar"; pp_loc_node buffer ~pad "LocalVar" region;
pp_var_decl buffer ~pad value pp_var_decl buffer ~pad value
and pp_var_decl buffer ~pad:(_,pc) decl = and pp_var_decl buffer ~pad:(_,pc) decl =
pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name.value; pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name;
pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.var_type; pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.var_type;
pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init
and pp_expr buffer ~pad:(_,pc as pad) = function and pp_expr buffer ~pad:(_,pc as pad) = function
ECase {value; _} -> ECase {value; region} ->
pp_node buffer ~pad "ECase"; pp_loc_node buffer ~pad "ECase" region;
pp_case pp_expr buffer ~pad value pp_case pp_expr buffer ~pad value
| ECond {value; _} -> | ECond {value; region} ->
pp_node buffer ~pad "ECond"; pp_loc_node buffer ~pad "ECond" region;
pp_cond_expr buffer ~pad value pp_cond_expr buffer ~pad value
| EAnnot {value; _} -> | EAnnot {value; region} ->
pp_node buffer ~pad "EAnnot"; pp_loc_node buffer ~pad "EAnnot" region;
pp_annotated buffer ~pad value pp_annotated buffer ~pad value
| ELogic e_logic -> | ELogic e_logic ->
pp_node buffer ~pad "ELogic"; pp_node buffer ~pad "ELogic";
@ -1333,137 +1348,137 @@ and pp_expr buffer ~pad:(_,pc as pad) = function
| EConstr e_constr -> | EConstr e_constr ->
pp_node buffer ~pad "EConstr"; pp_node buffer ~pad "EConstr";
pp_constr_expr buffer ~pad:(mk_pad 1 0 pc) e_constr pp_constr_expr buffer ~pad:(mk_pad 1 0 pc) e_constr
| ERecord {value; _} -> | ERecord {value; region} ->
pp_node buffer ~pad "ERecord"; pp_loc_node buffer ~pad "ERecord" region;
pp_injection pp_field_assign buffer ~pad value pp_ne_injection pp_field_assign buffer ~pad value
| EProj {value; _} -> | EProj {value; region} ->
pp_node buffer ~pad "EProj"; pp_loc_node buffer ~pad "EProj" region;
pp_projection buffer ~pad value pp_projection buffer ~pad value
| EMap e_map -> | EMap e_map ->
pp_node buffer ~pad "EMap"; pp_node buffer ~pad "EMap";
pp_map_expr buffer ~pad:(mk_pad 1 0 pc) e_map pp_map_expr buffer ~pad:(mk_pad 1 0 pc) e_map
| EVar {value; _} -> | EVar v ->
pp_node buffer ~pad "EVar"; pp_node buffer ~pad "EVar";
pp_ident buffer ~pad:(mk_pad 1 0 pc) value pp_ident buffer ~pad:(mk_pad 1 0 pc) v
| ECall {value; _} -> | ECall {value; region} ->
pp_node buffer ~pad "ECall"; pp_loc_node buffer ~pad "ECall" region;
pp_fun_call buffer ~pad value pp_fun_call buffer ~pad value
| EBytes {value; _} -> | EBytes b ->
pp_node buffer ~pad "EBytes"; pp_node buffer ~pad "EBytes";
pp_bytes buffer ~pad value pp_bytes buffer ~pad b
| EUnit _ -> | EUnit region ->
pp_node buffer ~pad "EUnit" pp_loc_node buffer ~pad "EUnit" region
| ETuple e_tuple -> | ETuple e_tuple ->
pp_node buffer ~pad "ETuple"; pp_node buffer ~pad "ETuple";
pp_tuple_expr buffer ~pad e_tuple pp_tuple_expr buffer ~pad e_tuple
| EPar {value; _} -> | EPar {value; region} ->
pp_node buffer ~pad "EPar"; pp_loc_node buffer ~pad "EPar" region;
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.inside pp_expr buffer ~pad:(mk_pad 1 0 pc) value.inside
and pp_list_expr buffer ~pad:(_,pc as pad) = function and pp_list_expr buffer ~pad:(_,pc as pad) = function
Cons {value; _} -> ECons {value; region} ->
pp_node buffer ~pad "Cons"; pp_loc_node buffer ~pad "ECons" region;
pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1; pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2 pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2
| List {value; _} -> | ENil region ->
pp_node buffer ~pad "List"; pp_loc_node buffer ~pad "ENil" region
pp_injection pp_expr buffer ~pad value | EListComp {value; region} ->
| Nil _ -> pp_loc_node buffer ~pad "EListComp" region;
pp_node buffer ~pad "Nil" if value.elements = None then
pp_node buffer ~pad:(mk_pad 1 0 pc) "[]"
else
pp_injection pp_expr buffer ~pad value
and pp_arith_expr buffer ~pad:(_,pc as pad) = function and pp_arith_expr buffer ~pad:(_,pc as pad) = function
Add {value; _} -> Add {value; region} ->
pp_bin_op "Add" buffer ~pad value pp_bin_op "Add" region buffer ~pad value
| Sub {value; _} -> | Sub {value; region} ->
pp_bin_op "Sub" buffer ~pad value pp_bin_op "Sub" region buffer ~pad value
| Mult {value; _} -> | Mult {value; region} ->
pp_bin_op "Mult" buffer ~pad value pp_bin_op "Mult" region buffer ~pad value
| Div {value; _} -> | Div {value; region} ->
pp_bin_op "Div" buffer ~pad value pp_bin_op "Div" region buffer ~pad value
| Mod {value; _} -> | Mod {value; region} ->
pp_bin_op "Mod" buffer ~pad value pp_bin_op "Mod" region buffer ~pad value
| Neg {value; _} -> | Neg {value; region} ->
pp_node buffer ~pad "Neg"; pp_loc_node buffer ~pad "Neg" region;
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg; pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg;
| Int {value; _} -> | Int i ->
pp_node buffer ~pad "Int"; pp_node buffer ~pad "Int";
pp_int buffer ~pad value pp_int buffer ~pad i
| Nat {value; _} -> | Nat n ->
pp_node buffer ~pad "Nat"; pp_node buffer ~pad "Nat";
pp_int buffer ~pad value pp_int buffer ~pad n
| Mutez {value; _} -> | Mutez m ->
pp_node buffer ~pad "Mutez"; pp_node buffer ~pad "Mutez";
pp_int buffer ~pad value pp_int buffer ~pad m
and pp_set_expr buffer ~pad:(_,pc as pad) = function and pp_set_expr buffer ~pad:(_,pc as pad) = function
SetInj {value; _} -> SetInj {value; region} ->
pp_node buffer ~pad "SetInj"; pp_loc_node buffer ~pad "SetInj" region;
pp_injection pp_expr buffer ~pad value pp_injection pp_expr buffer ~pad value
| SetMem {value; _} -> | SetMem {value; region} ->
pp_node buffer ~pad "SetMem"; pp_loc_node buffer ~pad "SetMem" region;
pp_expr buffer ~pad:(mk_pad 2 0 pc) value.set; pp_expr buffer ~pad:(mk_pad 2 0 pc) value.set;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.element pp_expr buffer ~pad:(mk_pad 2 1 pc) value.element
and pp_e_logic buffer ~pad = function and pp_e_logic buffer ~pad:(_, pc as pad) = function
BoolExpr e -> BoolExpr e ->
pp_node buffer ~pad "BoolExpr"; pp_node buffer ~pad "BoolExpr";
pp_bool_expr buffer ~pad e pp_bool_expr buffer ~pad:(mk_pad 1 0 pc) e
| CompExpr e -> | CompExpr e ->
pp_node buffer ~pad "CompExpr"; pp_node buffer ~pad "CompExpr";
pp_comp_expr buffer ~pad e pp_comp_expr buffer ~pad:(mk_pad 1 0 pc) e
and pp_bool_expr buffer ~pad:(_,pc as pad) = function and pp_bool_expr buffer ~pad:(_,pc as pad) = function
Or {value; _} -> Or {value; region} ->
pp_bin_op "Or" buffer ~pad value pp_bin_op "Or" region buffer ~pad value
| And {value; _} -> | And {value; region} ->
pp_bin_op "And" buffer ~pad value pp_bin_op "And" region buffer ~pad value
| Not {value; _} -> | Not {value; region} ->
let _, pc as pad = mk_pad 1 0 pc in pp_loc_node buffer ~pad "Not" region;
pp_node buffer ~pad "Not";
pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg
| False _ -> | False region ->
pp_node buffer ~pad:(mk_pad 1 0 pc) "False" pp_loc_node buffer ~pad "False" region
| True _ -> | True region ->
pp_node buffer ~pad:(mk_pad 1 0 pc) "True" pp_loc_node buffer ~pad "True" region
and pp_comp_expr buffer ~pad = function and pp_comp_expr buffer ~pad = function
Lt {value; _} -> Lt {value; region} ->
pp_bin_op "Lt" buffer ~pad value pp_bin_op "Lt" region buffer ~pad value
| Leq {value; _} -> | Leq {value; region} ->
pp_bin_op "Leq" buffer ~pad value pp_bin_op "Leq" region buffer ~pad value
| Gt {value; _} -> | Gt {value; region} ->
pp_bin_op "Gt" buffer ~pad value pp_bin_op "Gt" region buffer ~pad value
| Geq {value; _} -> | Geq {value; region} ->
pp_bin_op "Geq" buffer ~pad value pp_bin_op "Geq" region buffer ~pad value
| Equal {value; _} -> | Equal {value; region} ->
pp_bin_op "Equal" buffer ~pad value pp_bin_op "Equal" region buffer ~pad value
| Neq {value; _} -> | Neq {value; region} ->
pp_bin_op "Neq" buffer ~pad value pp_bin_op "Neq" region buffer ~pad value
and pp_constr_expr buffer ~pad:(_, pc as pad) = function and pp_constr_expr buffer ~pad:(_, pc as pad) = function
SomeApp {value=some_region,args; _} -> NoneExpr region ->
let constr = {value="Some"; region=some_region} in pp_loc_node buffer ~pad "NoneExpr" region
let app = constr, Some args in | SomeApp {value=_,args; region} ->
pp_node buffer ~pad "SomeApp"; pp_loc_node buffer ~pad "SomeApp" region;
pp_constr_app buffer ~pad app pp_tuple_expr buffer ~pad args
| NoneExpr _ -> | ConstrApp {value; region} ->
pp_node buffer ~pad "NoneExpr" pp_loc_node buffer ~pad "ConstrApp" region;
| ConstrApp {value; _} ->
pp_node buffer ~pad "ConstrApp";
pp_constr_app buffer ~pad:(mk_pad 1 0 pc) value pp_constr_app buffer ~pad:(mk_pad 1 0 pc) value
and pp_constr_app buffer ~pad (constr, args_opt) = and pp_constr_app buffer ~pad (constr, args_opt) =
pp_ident buffer ~pad constr.value; pp_ident buffer ~pad constr;
match args_opt with match args_opt with
None -> () None -> ()
| Some args -> pp_tuple_expr buffer ~pad args | Some args -> pp_tuple_expr buffer ~pad args
and pp_map_expr buffer ~pad = function and pp_map_expr buffer ~pad = function
MapLookUp {value; _} -> MapLookUp {value; region} ->
pp_node buffer ~pad "MapLookUp"; pp_loc_node buffer ~pad "MapLookUp" region;
pp_map_lookup buffer ~pad value pp_map_lookup buffer ~pad value
| MapInj {value; _} | BigMapInj {value; _} -> | MapInj {value; region} | BigMapInj {value; region} ->
pp_node buffer ~pad "MapInj"; pp_loc_node buffer ~pad "MapInj" region;
pp_injection pp_binding buffer ~pad value pp_injection pp_binding buffer ~pad value
and pp_tuple_expr buffer ~pad:(_,pc) {value; _} = and pp_tuple_expr buffer ~pad:(_,pc) {value; _} =
@ -1474,20 +1489,20 @@ and pp_tuple_expr buffer ~pad:(_,pc) {value; _} =
in List.iteri (apply length) exprs in List.iteri (apply length) exprs
and pp_string_expr buffer ~pad:(_,pc as pad) = function and pp_string_expr buffer ~pad:(_,pc as pad) = function
Cat {value; _} -> Cat {value; region} ->
pp_node buffer ~pad "Cat"; pp_loc_node buffer ~pad "Cat" region;
pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1; pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1;
pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2; pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2;
| String {value; _} -> | String s ->
pp_node buffer ~pad "String"; pp_node buffer ~pad "String";
pp_string buffer ~pad:(mk_pad 1 0 pc) value pp_string buffer ~pad:(mk_pad 1 0 pc) s
and pp_annotated buffer ~pad:(_,pc) (expr, t_expr) = and pp_annotated buffer ~pad:(_,pc) (expr, t_expr) =
pp_expr buffer ~pad:(mk_pad 2 0 pc) expr; pp_expr buffer ~pad:(mk_pad 2 0 pc) expr;
pp_type_expr buffer ~pad:(mk_pad 2 1 pc) t_expr pp_type_expr buffer ~pad:(mk_pad 2 1 pc) t_expr
and pp_bin_op node buffer ~pad:(_,pc as pad) op = and pp_bin_op node region buffer ~pad:(_,pc as pad) op =
pp_node buffer ~pad node; pp_loc_node buffer ~pad node region;
pp_expr buffer ~pad:(mk_pad 2 0 pc) op.arg1; pp_expr buffer ~pad:(mk_pad 2 0 pc) op.arg1;
pp_expr buffer ~pad:(mk_pad 2 1 pc) op.arg2 pp_expr buffer ~pad:(mk_pad 2 1 pc) op.arg2

2
src/passes/1-parser/pascaligo/ParserLog.mli
View File

@ -13,4 +13,6 @@ val path_to_string : AST.path -> string
val pattern_to_string : AST.pattern -> string val pattern_to_string : AST.pattern -> string
val instruction_to_string : AST.instruction -> string val instruction_to_string : AST.instruction -> string
(* Pretty-printing of the AST *)
val pp_ast : Buffer.t -> AST.t -> unit val pp_ast : Buffer.t -> AST.t -> unit

12
src/passes/1-parser/pascaligo/dune
View File

@ -11,7 +11,7 @@
(modules AST pascaligo Parser ParserLog LexToken) (modules AST pascaligo Parser ParserLog LexToken)
(libraries (libraries
parser_shared parser_shared
hex hex
simple-utils simple-utils
tezos-utils tezos-utils
) )
@ -20,12 +20,12 @@
(executable (executable
(name LexerMain) (name LexerMain)
(libraries (libraries
hex hex
simple-utils simple-utils
tezos-utils tezos-utils
parser_pascaligo) parser_pascaligo)
(modules (modules
LexerMain LexerMain
) )
(flags (:standard -open Parser_shared -open Parser_pascaligo)) (flags (:standard -open Parser_shared -open Parser_pascaligo))
@ -33,9 +33,9 @@
(executable (executable
(name ParserMain) (name ParserMain)
(libraries (libraries
parser_pascaligo) parser_pascaligo)
(modules (modules
ParserMain ParserMain
) )
(flags (:standard -open Simple_utils -open Parser_shared -open Parser_pascaligo)) (flags (:standard -open Simple_utils -open Parser_shared -open Parser_pascaligo))

96
src/passes/2-simplify/pascaligo.ml
View File

@ -57,17 +57,6 @@ module Errors = struct
] in ] in
error ~data title message error ~data title message
let unsupported_arith_op expr =
let title () = "arithmetic expressions" in
let message () =
Format.asprintf "this arithmetic operator is not supported yet" in
let expr_loc = Raw.expr_to_region expr in
let data = [
("expr_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
] in
error ~data title message
let unsupported_non_var_pattern p = let unsupported_non_var_pattern p =
let title () = "pattern is not a variable" in let title () = "pattern is not a variable" in
let message () = let message () =
@ -175,15 +164,14 @@ let return_let_in ?loc binder rhs = ok @@ fun expr'_opt ->
| Some expr' -> ok @@ e_let_in ?loc binder rhs expr' | Some expr' -> ok @@ e_let_in ?loc binder rhs expr'
let return_statement expr = ok @@ fun expr'_opt -> let return_statement expr = ok @@ fun expr'_opt ->
let expr = expr in
match expr'_opt with match expr'_opt with
| None -> ok @@ expr | None -> ok @@ expr
| Some expr' -> ok @@ e_sequence expr expr' | Some expr' -> ok @@ e_sequence expr expr'
let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
match t with match t with
| TPar x -> simpl_type_expression x.value.inside TPar x -> simpl_type_expression x.value.inside
| TAlias v -> ( | TVar v -> (
match List.assoc_opt v.value type_constants with match List.assoc_opt v.value type_constants with
| Some s -> ok @@ T_constant (s , []) | Some s -> ok @@ T_constant (s , [])
| None -> ok @@ T_variable v.value | None -> ok @@ T_variable v.value
@ -222,12 +210,10 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
| TSum s -> | TSum s ->
let aux (v:Raw.variant Raw.reg) = let aux (v:Raw.variant Raw.reg) =
let args = let args =
match v.value.args with match v.value.arg with
None -> [] None -> []
| Some (_, t_expr) -> | Some (_, TProd product) -> npseq_to_list product.value
match t_expr with | Some (_, t_expr) -> [t_expr] in
TProd product -> npseq_to_list product.value
| _ -> [t_expr] in
let%bind te = simpl_list_type_expression @@ args in let%bind te = simpl_list_type_expression @@ args in
ok (v.value.constr.value, te) ok (v.value.constr.value, te)
in in
@ -303,7 +289,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let%bind fields = bind_list let%bind fields = bind_list
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v)) @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ pseq_to_list r.value.elements in @@ npseq_to_list r.value.ne_elements in
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = SMap.add k v prev in
return @@ e_record (List.fold_left aux SMap.empty fields) return @@ e_record (List.fold_left aux SMap.empty fields)
| EProj p -> simpl_projection p | EProj p -> simpl_projection p
@ -460,19 +446,17 @@ and simpl_logic_expression (t:Raw.logic_expr) : expression result =
and simpl_list_expression (t:Raw.list_expr) : expression result = and simpl_list_expression (t:Raw.list_expr) : expression result =
let return x = ok x in let return x = ok x in
match t with match t with
| Cons c -> ECons c ->
simpl_binop "CONS" c simpl_binop "CONS" c
| List lst -> ( | EListComp lst ->
let (lst , loc) = r_split lst in let (lst , loc) = r_split lst in
let%bind lst' = let%bind lst' =
bind_map_list simpl_expression @@ bind_map_list simpl_expression @@
pseq_to_list lst.elements in pseq_to_list lst.elements in
return @@ e_list ~loc lst' return @@ e_list ~loc lst'
) | ENil reg ->
| Nil reg -> (
let loc = Location.lift reg in let loc = Location.lift reg in
return @@ e_list ~loc [] return @@ e_list ~loc []
)
and simpl_set_expression (t:Raw.set_expr) : expression result = and simpl_set_expression (t:Raw.set_expr) : expression result =
match t with match t with
@ -668,13 +652,13 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
let%bind body = simpl_block l.block.value in let%bind body = simpl_block l.block.value in
let%bind body = body None in let%bind body = body None in
return_statement @@ e_loop cond body return_statement @@ e_loop cond body
| Loop (For (ForInt fi)) -> | Loop (For (ForInt fi)) ->
let%bind loop = simpl_for_int fi.value in let%bind loop = simpl_for_int fi.value in
let%bind loop = loop None in let%bind loop = loop None in
return_statement @@ loop return_statement @@ loop
| Loop (For (ForCollect fc)) -> | Loop (For (ForCollect fc)) ->
let%bind loop = simpl_for_collect fc.value in let%bind loop = simpl_for_collect fc.value in
let%bind loop = loop None in let%bind loop = loop None in
return_statement @@ loop return_statement @@ loop
| Cond c -> ( | Cond c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
@ -878,7 +862,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
ok (List.hd t') in ok (List.hd t') in
let get_toplevel (t : Raw.pattern) = let get_toplevel (t : Raw.pattern) =
match t with match t with
| PCons x -> ( | PList PCons x -> (
let (x' , lst) = x.value in let (x' , lst) = x.value in
match lst with match lst with
| [] -> ok x' | [] -> ok x'
@ -887,8 +871,8 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
| pattern -> ok pattern in | pattern -> ok pattern in
let get_constr (t: Raw.pattern) = let get_constr (t: Raw.pattern) =
match t with match t with
| PConstr v -> ( | PConstr (PConstrApp v) -> (
let (const , pat_opt) = v.value in let const, pat_opt = v.value in
let%bind pat = let%bind pat =
trace_option (unsupported_cst_constr t) @@ trace_option (unsupported_cst_constr t) @@
pat_opt in pat_opt in
@ -896,12 +880,6 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
let%bind var = get_var single_pat in let%bind var = get_var single_pat in
ok (const.value , var) ok (const.value , var)
) )
(*
| PConstr {value = constr, Some tuple; _} ->
let%bind var = get_single (PTuple tuple) >>? get_var in
ok (constr.value, var)
| PConstr {value = constr, None; _} ->
*)
| _ -> fail @@ only_constructors t in | _ -> fail @@ only_constructors t in
let%bind patterns = let%bind patterns =
let aux (x , y) = let aux (x , y) =
@ -909,19 +887,19 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
ok (x' , y) ok (x' , y)
in bind_map_list aux t in in bind_map_list aux t in
match patterns with match patterns with
| [(PFalse _ , f) ; (PTrue _ , t)] | [(PConstr PFalse _ , f) ; (PConstr PTrue _ , t)]
| [(PTrue _ , t) ; (PFalse _ , f)] -> | [(PConstr PTrue _ , t) ; (PConstr PFalse _ , f)] ->
ok @@ Match_bool {match_true = t ; match_false = f} ok @@ Match_bool {match_true = t ; match_false = f}
| [(PSome v , some) ; (PNone _ , none)] | [(PConstr PSomeApp v , some) ; (PConstr PNone _ , none)]
| [(PNone _ , none) ; (PSome v , some)] -> ( | [(PConstr PNone _ , none) ; (PConstr PSomeApp v , some)] -> (
let (_, v) = v.value in let (_, v) = v.value in
let%bind v = match v.value.inside with let%bind v = match v.value.inside with
| PVar v -> ok v.value | PVar v -> ok v.value
| p -> fail @@ unsupported_deep_Some_patterns p in | p -> fail @@ unsupported_deep_Some_patterns p in
ok @@ Match_option {match_none = none ; match_some = (v, some) } ok @@ Match_option {match_none = none ; match_some = (v, some) }
) )
| [(PCons c , cons) ; (PList (PNil _) , nil)] | [(PList PCons c, cons) ; (PList (PNil _), nil)]
| [(PList (PNil _) , nil) ; (PCons c, cons)] -> | [(PList (PNil _), nil) ; (PList PCons c, cons)] ->
let%bind (a, b) = let%bind (a, b) =
match c.value with match c.value with
| a, [(_, b)] -> | a, [(_, b)] ->
@ -1002,11 +980,11 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
are implemented using a MAP_FOLD, LIST_FOLD or SET_FOLD: are implemented using a MAP_FOLD, LIST_FOLD or SET_FOLD:
``` pseudo Ast_simplified ``` pseudo Ast_simplified
let #COMPILER#folded_record = list_fold( mylist , let #COMPILER#folded_record = list_fold( mylist ,
record st = st; acc = acc; end; record st = st; acc = acc; end;
lamby = fun arguments -> ( lamby = fun arguments -> (
let #COMPILER#acc = arguments.0 in let #COMPILER#acc = arguments.0 in
let #COMPILER#elt = arguments.1 in let #COMPILER#elt = arguments.1 in
#COMPILER#acc.myint := #COMPILER#acc.myint + #COMPILER#elt ; #COMPILER#acc.myint := #COMPILER#acc.myint + #COMPILER#elt ;
#COMPILER#acc.myst := #COMPILER#acc.myst ^ "to" ; #COMPILER#acc.myst := #COMPILER#acc.myst ^ "to" ;
#COMPILER#acc #COMPILER#acc
@ -1017,7 +995,7 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
myint := #COMPILER#folded_record.myint ; myint := #COMPILER#folded_record.myint ;
} }
``` ```
We are performing the following steps: We are performing the following steps:
1) Simplifying the for body using ̀simpl_block` 1) Simplifying the for body using ̀simpl_block`
@ -1032,10 +1010,10 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
- free variable of name X as rhs ==> accessor `#COMPILER#acc.X` - free variable of name X as rhs ==> accessor `#COMPILER#acc.X`
- free variable of name X as lhs ==> accessor `#COMPILER#acc.X` - free variable of name X as lhs ==> accessor `#COMPILER#acc.X`
And, in the case of a map: And, in the case of a map:
- references to the iterated key ==> variable `#COMPILER#elt_key` - references to the iterated key ==> variable `#COMPILER#elt_key`
- references to the iterated value ==> variable `#COMPILER#elt_value` - references to the iterated value ==> variable `#COMPILER#elt_value`
in the case of a set/list: in the case of a set/list:
- references to the iterated value ==> variable `#COMPILER#elt` - references to the iterated value ==> variable `#COMPILER#elt`
5) Append the return value to the body 5) Append the return value to the body
@ -1045,18 +1023,18 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
tuple holding: tuple holding:
* In the case of `list` or ̀set`: * In the case of `list` or ̀set`:
( folding record , current list/set element ) as ( folding record , current list/set element ) as
( #COMPILER#acc , #COMPILER#elt ) ( #COMPILER#acc , #COMPILER#elt )
* In the case of `map`: * In the case of `map`:
( folding record , current map key , current map value ) as ( folding record , current map key , current map value ) as
( #COMPILER#acc , #COMPILER#elt_key , #COMPILER#elt_value ) ( #COMPILER#acc , #COMPILER#elt_key , #COMPILER#elt_value )
7) Build the lambda using the final body of (6) 7) Build the lambda using the final body of (6)
8) Build a sequence of assignments for all the captured variables 8) Build a sequence of assignments for all the captured variables
to their new value, namely an access to the folded record to their new value, namely an access to the folded record
(#COMPILER#folded_record) (#COMPILER#folded_record)
9) Attach the sequence of 8 to the ̀let .. in` declaration 9) Attach the sequence of 8 to the ̀let .. in` declaration
of #COMPILER#folded_record of #COMPILER#folded_record
**) **)
@ -1095,7 +1073,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
if (List.mem name captured_name_list) then if (List.mem name captured_name_list) then
(* replace references to fold accumulator as lhs *) (* replace references to fold accumulator as lhs *)
ok @@ e_accessor (e_variable "#COMPILER#acc") [Access_record name] ok @@ e_accessor (e_variable "#COMPILER#acc") [Access_record name]
else match fc.collection with else match fc.collection with
(* loop on map *) (* loop on map *)
| Map _ -> | Map _ ->
let k' = e_variable "#COMPILER#collec_elt_k" in let k' = e_variable "#COMPILER#collec_elt_k" in
@ -1127,7 +1105,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
(* STEP 6 *) (* STEP 6 *)
let for_body = let for_body =
let ( arg_access: Types.access_path -> expression ) = e_accessor (e_variable "arguments") in let ( arg_access: Types.access_path -> expression ) = e_accessor (e_variable "arguments") in
( match fc.collection with ( match fc.collection with
| Map _ -> | Map _ ->
(* let acc = arg_access [Access_tuple 0 ; Access_tuple 0] in (* let acc = arg_access [Access_tuple 0 ; Access_tuple 0] in
let collec_elt_v = arg_access [Access_tuple 1 ; Access_tuple 0] in let collec_elt_v = arg_access [Access_tuple 1 ; Access_tuple 0] in
@ -1158,8 +1136,8 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
let access = e_accessor (e_variable "#COMPILER#folded_record") let access = e_accessor (e_variable "#COMPILER#folded_record")
[Access_record captured_varname] in [Access_record captured_varname] in
let assign = e_assign captured_varname [] access in let assign = e_assign captured_varname [] access in
match prev with match prev with
| None -> Some assign | None -> Some assign
| Some p -> Some (e_sequence p assign) in | Some p -> Some (e_sequence p assign) in
let reassign_sequence = List.fold_left assign_back None captured_name_list in let reassign_sequence = List.fold_left assign_back None captured_name_list in
(* STEP 9 *) (* STEP 9 *)
@ -1170,4 +1148,4 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
return_statement @@ final_sequence return_statement @@ final_sequence
let simpl_program : Raw.ast -> program result = fun t -> let simpl_program : Raw.ast -> program result = fun t ->
bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl

1
src/passes/2-simplify/pascaligo.mli
View File

@ -9,7 +9,6 @@ module SMap = Map.String
module Errors : module Errors :
sig sig
val bad_bytes : Location.t -> string -> unit -> error val bad_bytes : Location.t -> string -> unit -> error
val unsupported_arith_op : Raw.expr -> unit -> error
end end

24
vendors/ligo-utils/simple-utils/region.ml vendored
View File

@ -90,24 +90,18 @@ let make ~(start: Pos.t) ~(stop: Pos.t) =
info start_offset stop#line horizontal stop_offset info start_offset stop#line horizontal stop_offset
method compact ?(file=true) ?(offsets=true) mode = method compact ?(file=true) ?(offsets=true) mode =
let start_line = start#line let prefix = if file then start#file ^ ":" else ""
and stop_line = stop#line in and start_str = start#anonymous ~offsets mode
let start_str = start#anonymous ~offsets mode
and stop_str = stop#anonymous ~offsets mode in and stop_str = stop#anonymous ~offsets mode in
if start#file = stop#file then if start#file = stop#file then
if file then if start#line = stop#line then
sprintf "%s:%s-%s" start#file sprintf "%s%s-%i" prefix start_str
start_str (if offsets then stop#offset mode
(if start_line = stop_line else stop#column mode)
then stop#column mode |> string_of_int
else stop_str)
else else
sprintf "%s-%s" sprintf "%s%s-%s" prefix start_str stop_str
start_str else sprintf "%s:%s-%s:%s"
(if start_line = stop_line start#file start_str stop#file stop_str
then stop#column mode |> string_of_int
else stop_str)
else sprintf "%s:%s-%s:%s" start#file start_str stop#file stop_str
end end
(* Special regions *) (* Special regions *)