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

Fixed last commit (renaming of TStringLiteral, adding --pretty)

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-05-03 10:40:11 +02:00
parent f4b9261104
commit 0aa69ed35b
10 changed files with 232 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/passes/1-parser/cameligo.ml
View File

@ -19,7 +19,8 @@ module SubIO =
ext : string; (* ".mligo" *)
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
let options : options =
@ -34,6 +35,7 @@ module SubIO =
method mode = `Point
method cmd = EvalOpt.Quiet
method mono = false
method pretty = false
end
let make =
@ -46,6 +48,7 @@ module SubIO =
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
~pretty:options#mono
end
module Parser =

187
src/passes/1-parser/cameligo/Pretty.ml Normal file
View File

@ -0,0 +1,187 @@
[@@@warning "-42"]
open AST
module Region = Simple_utils.Region
open! Region
open! PPrint
let paragraph (s : string) = flow (break 1) (words s)
let rec make ast =
let app decl = group (pp_declaration decl) in
separate_map hardline app (Utils.nseq_to_list ast.decl)
and pp_declaration = function
Let decl -> pp_let_decl decl
| TypeDecl decl -> pp_type_decl decl
and pp_let_decl Region.{value; _} =
let _, rec_opt, binding, attr = value in
let rec_str =
match rec_opt with
None -> ""
| Some _ -> " rec" in
string "let" ^^ string rec_str
^/^ pp_let_binding binding ^/^ pp_attributes attr
and pp_attributes attr =
let sep = string ";" ^^ break 1 in
let make s = string "[@@" ^^ string s.value ^^ string "]"
in separate_map sep make attr
and pp_string Region.{value; _} = string value
and pp_let_binding (binding : let_binding) =
let {binders; lhs_type; let_rhs; _} = binding in
let patterns = Utils.nseq_to_list binders in
let patterns = flow (break 1) (List.map pp_pattern patterns) in
let lhs_type =
match lhs_type with
None -> string ""
| Some (_, t_expr) -> string " :" ^/^ pp_type_expr t_expr in
let let_rhs = pp_expr let_rhs in
patterns ^^ lhs_type ^^ string " =" ^/^ let_rhs
and pp_pattern = function
PConstr p -> pp_pconstr p
| PUnit _ -> string "()"
| PFalse _ -> string "false"
| PTrue _ -> string "true"
| PVar v -> pp_string v
| PInt i -> pp_int i
| PNat n -> pp_nat n
| PBytes b -> pp_bytes b
| PString s -> pp_string s
| PWild _ -> string "_"
| PList l -> pp_plist l
| PTuple t -> pp_ptuple t
| PPar p -> pp_ppar p
| PRecord r -> pp_precord r
| PTyped t -> pp_ptyped t
and pp_pconstr = function
PNone _ -> string "None"
| PSomeApp p -> pp_some p
| PConstrApp a -> pp_c_app a
and pp_c_app Region.{value; _} =
match value with
constr, None -> pp_string constr
| constr, Some pat -> pp_string constr ^/^ pp_pattern pat
and pp_some Region.{value; _} =
string "Some" ^/^ pp_pattern (snd value)
and pp_int Region.{value; _} = string (fst value)
and pp_nat Region.{value; _} = string (fst value)
and pp_bytes Region.{value; _} = string (fst value)
and pp_ppar Region.{value; _} =
let {lpar; inside; rpar} = value in
string "(" ^^ pp_pattern inside ^^ string ")"
and pp_plist = function
PListComp cmp -> pp_list_comp cmp
| PCons cons -> pp_cons cons
and pp_list_comp Region.{value; _} =
let items = Utils.sepseq_to_list value.elements in
let sep = string ";" ^^ break 1 in
let items = separate_map sep pp_pattern items
in string "[" ^^ items ^^ string "]"
and pp_cons Region.{value; _} =
let patt1, _, patt2 = value in
pp_pattern patt1 ^^ string " ::" ^/^ pp_pattern patt2
and pp_ptuple Region.{value; _} =
let cmp = Utils.nsepseq_to_list value in
let sep = string "," ^^ break 1 in
separate_map sep pp_pattern cmp
and pp_precord Region.{value; _} =
let fields = value.ne_elements in
let fields = Utils.nsepseq_to_list fields in
let sep = string ";" ^^ break 1 in
let fields = separate_map sep pp_field_pattern fields
in string "{" ^^ fields ^^ string "}"
and pp_field_pattern Region.{value; _} =
let {field_name; pattern; _} = value in
pp_string field_name ^^ string " =" ^/^ pp_pattern pattern
and pp_ptyped Region.{value; _} =
let {pattern; type_expr; _} = value in
pp_pattern pattern ^^ string " :" ^/^ pp_type_expr type_expr
and pp_type_decl decl =
let {name; type_expr; _} = decl.value in
string "type" ^/^ string name.value
^/^ string "=" ^/^ pp_type_expr type_expr
and pp_expr expr =
string "TODO:pp_expr"
and pp_type_expr = function
TProd cartesian -> pp_cartesian cartesian
| TSum sum -> pp_variants sum
| TRecord fields -> pp_fields fields
| TApp t_app -> pp_type_app t_app
| TFun fun_type -> pp_fun_type fun_type
| TPar par -> pp_type_par par
| TVar var -> pp_string var
| TString s -> pp_string s
and pp_cartesian Region.{value; _} =
let cmp = Utils.nsepseq_to_list value in
let sep = string " *" ^^ break 1 in
separate_map sep pp_type_expr cmp
and pp_variants Region.{value; _} =
let variants = Utils.nsepseq_to_list value
and sep = string " |" ^^ break 1 in
separate_map sep pp_variant variants
and pp_variant Region.{value; _} =
let {constr; arg} = value in
match arg with
None -> pp_string constr
| Some (_, t_expr) ->
pp_string constr ^^ string " of" ^/^ pp_type_expr t_expr
and pp_fields Region.{value; _} =
let fields = value.ne_elements in
let fields = Utils.nsepseq_to_list fields in
let sep = string ";" ^^ break 1 in
let fields = separate_map sep pp_field_decl fields
in string "{" ^^ fields ^^ string "}"
and pp_field_decl Region.{value; _} =
let {field_name; field_type; _} = value in
let name = pp_string field_name in
let t_expr = pp_type_expr field_type
in name ^^ string " :" ^/^ t_expr
and pp_type_app Region.{value; _} =
let ctor, tuple = value
in pp_type_tuple tuple ^/^ pp_type_constr ctor
and pp_type_tuple Region.{value; _} =
let {lpar; inside; rpar} = value in
match inside with
t_expr, [] -> pp_type_expr t_expr
| seq -> let sep = string "," ^^ break 1 in
let lst = Utils.nsepseq_to_list seq in
let cmp = separate_map sep pp_type_expr lst
in string "(" ^^ cmp ^^ string ")"
and pp_type_constr ctor =
string ctor.value
and pp_fun_type Region.{value; _} =
let lhs, _, rhs = value in
pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs
and pp_type_par Region.{value; _} =
let {lpar; inside; rpar} = value in
string "(" ^^ pp_type_expr inside ^^ string ")"

5
src/passes/1-parser/pascaligo.ml
View File

@ -19,7 +19,8 @@ module SubIO =
ext : string; (* ".ligo" *)
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
let options : options =
@ -34,6 +35,7 @@ module SubIO =
method mode = `Point
method cmd = EvalOpt.Quiet
method mono = false
method pretty = false
end
let make =
@ -46,6 +48,7 @@ module SubIO =
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
~pretty:options#pretty
end
module Parser =

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

@ -185,7 +185,7 @@ and type_expr =
| TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg
| TVar of variable
| TStringLiteral of Lexer.lexeme reg
| TString of Lexer.lexeme reg
and cartesian = (type_expr, times) nsepseq reg
@ -659,7 +659,7 @@ let type_expr_to_region = function
| TApp {region; _}
| TFun {region; _}
| TPar {region; _}
| TStringLiteral {region; _}
| TString {region; _}
| TVar {region; _} -> region
let rec expr_to_region = function

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

@ -160,9 +160,9 @@ cartesian:
in TProd {region; value} }
core_type:
type_name { TVar $1 }
| "<string>" { TStringLiteral $1 }
| par(type_expr) { TPar $1 }
type_name { TVar $1 }
| "<string>" { TString $1 }
| par(type_expr) { TPar $1 }
| type_name type_tuple {
let region = cover $1.region $2.region
in TApp {region; value = $1,$2}

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

@ -153,7 +153,7 @@ and print_type_expr state = function
| TFun type_fun -> print_type_fun state type_fun
| TPar par_type -> print_par_type state par_type
| TVar type_var -> print_var state type_var
| TStringLiteral s -> print_string state s
| TString str -> print_string state str
and print_cartesian state {value; _} =
print_nsepseq state "*" print_type_expr value
@ -398,9 +398,9 @@ and print_for_int state ({value; _} : for_int reg) =
print_var_assign state assign;
print_token state kwd_to "to";
print_expr state bound;
match kwd_step with
match kwd_step with
| None -> ();
| Some kwd_step ->
| Some kwd_step ->
print_token state kwd_step "step";
match step with
| None -> ();
@ -941,8 +941,8 @@ and pp_type_expr state = function
field_decl.value in
let fields = Utils.nsepseq_to_list value.ne_elements in
List.iteri (List.length fields |> apply) fields
| TStringLiteral s ->
pp_node state "String";
| TString s ->
pp_node state "TString";
pp_string (state#pad 1 0) s
and pp_cartesian state {value; _} =

5
src/passes/1-parser/reasonligo.ml
View File

@ -22,7 +22,8 @@ module SubIO =
ext : string; (* ".religo" *)
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
let options : options =
@ -37,6 +38,7 @@ module SubIO =
method mode = `Point
method cmd = EvalOpt.Quiet
method mono = false
method pretty = false
end
let make =
@ -49,6 +51,7 @@ module SubIO =
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
~pretty:options#pretty
end
module Parser =

10
src/passes/1-parser/reasonligo/Parser.mly
View File

@ -205,9 +205,9 @@ type_args:
| fun_type { $1, [] }
core_type:
type_name { TVar $1 }
| "<string>" { TStringLiteral $1 }
| par(fun_type) { TPar $1 }
type_name { TVar $1 }
| "<string>" { TString $1 }
| par(fun_type) { TPar $1 }
| module_name "." type_name {
let module_name = $1.value in
let type_name = $3.value in
@ -938,10 +938,10 @@ sequence_or_record_in:
field_name = $1;
assignment = ghost;
field_expr = EVar $1 }
in
in
let field_name = {$1 with value} in
let (comma, elts) = $2 in
let r_elts = Utils.nsepseq_cons field_name comma elts in
let r_elts = Utils.nsepseq_cons field_name comma elts in
PaRecord {r_elts; r_terminator = None}
}

6
src/passes/2-concrete_to_imperative/cameligo.ml
View File

@ -169,7 +169,7 @@ open Operators.Concrete_to_imperative.Cameligo
let r_split = Location.r_split
let get_t_string_singleton_opt = function
| Raw.TStringLiteral s -> Some (String.(sub s.value 1 ((length s.value)-2)))
| Raw.TString s -> Some (String.(sub s.value 1 (length s.value - 2)))
| _ -> None
let rec pattern_to_var : Raw.pattern -> _ = fun p ->
@ -249,7 +249,7 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
let (x,loc) = r_split x in
let (name, tuple) = x in
( match name.value with
| "michelson_or" ->
| "michelson_or" ->
let lst = npseq_to_list tuple.value.inside in
(match lst with
| [a ; b ; c ; d ] -> (
@ -318,7 +318,7 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
@@ npseq_to_list s in
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t ~loc @@ T_sum m
| TStringLiteral _s -> simple_fail "we don't support singleton string type"
| TString _s -> simple_fail "we don't support singleton string type"
and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with

30
src/passes/2-concrete_to_imperative/pascaligo.ml
View File

@ -152,7 +152,7 @@ let return_statement expr = ok @@ fun expr'_opt ->
| Some expr' -> ok @@ e_sequence expr expr'
let get_t_string_singleton_opt = function
| Raw.TStringLiteral s -> Some (String.(sub s.value 1 ((length s.value)-2)))
| Raw.TString s -> Some (String.(sub s.value 1 (length s.value -2)))
| _ -> None
@ -176,7 +176,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
let (x, loc) = r_split x in
let (name, tuple) = x in
(match name.value with
| "michelson_or" ->
| "michelson_or" ->
let lst = npseq_to_list tuple.value.inside in
(match lst with
| [a ; b ; c ; d ] -> (
@ -248,7 +248,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
@@ npseq_to_list s in
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t ~loc @@ T_sum m
| TStringLiteral _s -> simple_fail "we don't support singleton string type"
| TString _s -> simple_fail "we don't support singleton string type"
and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with
@ -461,7 +461,7 @@ and compile_update = fun (u:Raw.update Region.reg) ->
let (name, path) = compile_path u.record in
let record = match path with
| [] -> e_variable (Var.of_name name)
| _ -> e_accessor_list (e_variable (Var.of_name name)) path in
| _ -> e_accessor_list (e_variable (Var.of_name name)) path in
let updates = u.updates.value.ne_elements in
let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) =
@ -471,13 +471,13 @@ and compile_update = fun (u:Raw.update Region.reg) ->
in
bind_map_list aux @@ npseq_to_list updates
in
let aux ur (path, expr) =
let aux ur (path, expr) =
let rec aux record = function
| [] -> failwith "error in parsing"
| hd :: [] -> ok @@ e_record_update ~loc record hd expr
| hd :: tl ->
| hd :: tl ->
let%bind expr = (aux (e_record_accessor ~loc record hd) tl) in
ok @@ e_record_update ~loc record hd expr
ok @@ e_record_update ~loc record hd expr
in
aux ur path in
bind_fold_list aux record updates'
@ -645,11 +645,11 @@ and compile_fun_decl :
let binder = Var.of_name binder in
let fun_name = Var.of_name fun_name.value in
let fun_type = t_function input_type output_type in
let expression : expression =
let expression : expression =
e_lambda ~loc binder (Some input_type)(Some output_type) result in
let%bind expression = match kwd_recursive with
None -> ok @@ expression |
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok ((fun_name, Some fun_type), expression)
@ -680,11 +680,11 @@ and compile_fun_decl :
bind_fold_right_list aux result body in
let fun_name = Var.of_name fun_name.value in
let fun_type = t_function input_type output_type in
let expression : expression =
let expression : expression =
e_lambda ~loc binder (Some input_type)(Some output_type) result in
let%bind expression = match kwd_recursive with
None -> ok @@ expression |
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok ((fun_name, Some fun_type), expression)
@ -713,7 +713,7 @@ and compile_fun_expression :
let fun_type = t_function input_type output_type in
let expression = match kwd_recursive with
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
| Some _ -> e_recursive ~loc binder fun_type
| Some _ -> e_recursive ~loc binder fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok (Some fun_type , expression)
@ -744,7 +744,7 @@ and compile_fun_expression :
let fun_type = t_function input_type output_type in
let expression = match kwd_recursive with
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
| Some _ -> e_recursive ~loc binder fun_type
| Some _ -> e_recursive ~loc binder fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok (Some fun_type , expression)
@ -857,7 +857,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
compile_block value
| ShortBlock {value; _} ->
compile_statements @@ fst value.inside in
let%bind match_true = match_true None in
let%bind match_false = match_false None in
return_statement @@ e_cond ~loc expr match_true match_false
@ -943,7 +943,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
(fun (key, value) map -> (e_map_add key value map))
inj
(e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
in
in
return_statement @@ e_ez_assign ~loc name access_path assigns
)
| SetPatch patch -> (