From c32ace3afc4a5f5823b32d58cf3388b728192dac Mon Sep 17 00:00:00 2001 From: Galfour Date: Tue, 28 May 2019 15:36:14 +0000 Subject: [PATCH 1/8] propagate source code locations --- src/ast_simplified/PP.ml | 2 +- src/ast_simplified/combinators.ml | 106 ++++--- src/ast_simplified/misc.ml | 6 +- src/ast_simplified/types.ml | 4 +- src/simplify/camligo.ml | 14 +- src/simplify/pascaligo.ml | 322 +++++++++++--------- src/typer/typer.ml | 42 +-- vendors/ligo-utils/simple-utils/location.ml | 7 +- 8 files changed, 278 insertions(+), 225 deletions(-) diff --git a/src/ast_simplified/PP.ml b/src/ast_simplified/PP.ml index 22a16b58f..5cd46827c 100644 --- a/src/ast_simplified/PP.ml +++ b/src/ast_simplified/PP.ml @@ -30,7 +30,7 @@ let literal ppf (l:literal) = match l with | Literal_address s -> fprintf ppf "@%S" s | Literal_operation _ -> fprintf ppf "Operation(...bytes)" -let rec expression ppf (e:expression) = match e with +let rec expression ppf (e:expression) = match Location.unwrap e with | E_literal l -> literal ppf l | E_variable name -> fprintf ppf "%s" name | E_application (f, arg) -> fprintf ppf "(%a)@(%a)" expression f expression arg diff --git a/src/ast_simplified/combinators.ml b/src/ast_simplified/combinators.ml index 7fd963b0f..654d55024 100644 --- a/src/ast_simplified/combinators.ml +++ b/src/ast_simplified/combinators.ml @@ -35,76 +35,79 @@ let t_map key value = (T_constant ("map", [key ; value])) let make_name (s : string) : name = s -let e_var (s : string) : expression = E_variable s +let e_var ?loc (s : string) : expression = Location.wrap ?loc @@ E_variable s +let e_literal ?loc l : expression = Location.wrap ?loc @@ E_literal l +let e_unit ?loc () : expression = Location.wrap ?loc @@ E_literal (Literal_unit) +let e_int ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_int n) +let e_nat ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_nat n) +let e_bool ?loc b : expression = Location.wrap ?loc @@ E_literal (Literal_bool b) +let e_string ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_string s) +let e_address ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_address s) +let e_tez ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_tez s) +let e_bytes ?loc b : expression = Location.wrap ?loc @@ E_literal (Literal_bytes (Bytes.of_string b)) +let e_record ?loc map : expression = Location.wrap ?loc @@ E_record map +let e_tuple ?loc lst : expression = Location.wrap ?loc @@ E_tuple lst +let e_some ?loc s : expression = Location.wrap ?loc @@ E_constant ("SOME", [s]) +let e_none ?loc () : expression = Location.wrap ?loc @@ E_constant ("NONE", []) +let e_map_update ?loc k v old : expression = Location.wrap ?loc @@ E_constant ("MAP_UPDATE" , [k ; v ; old]) +let e_map ?loc lst : expression = Location.wrap ?loc @@ E_map lst +let e_list ?loc lst : expression = Location.wrap ?loc @@ E_list lst +let e_pair ?loc a b : expression = Location.wrap ?loc @@ E_tuple [a; b] +let e_constructor ?loc s a : expression = Location.wrap ?loc @@ E_constructor (s , a) +let e_matching ?loc a b : expression = Location.wrap ?loc @@ E_matching (a , b) +let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) +let e_accessor ?loc a b = Location.wrap ?loc @@ E_accessor (a , b) +let e_accessor_props ?loc a b = e_accessor ?loc a (List.map (fun x -> Access_record x) b) +let e_variable ?loc v = Location.wrap ?loc @@ E_variable v +let e_failwith ?loc v = Location.wrap ?loc @@ E_failwith v +let e_skip ?loc () = Location.wrap ?loc @@ E_skip +let e_loop ?loc cond body = Location.wrap ?loc @@ E_loop (cond , body) +let e_sequence ?loc a b = Location.wrap ?loc @@ E_sequence (a , b) +let e_let_in ?loc binder rhs result = Location.wrap ?loc @@ E_let_in { binder ; rhs ; result } +let e_annotation ?loc expr ty = Location.wrap ?loc @@ E_annotation (expr , ty) +let e_application ?loc a b = Location.wrap ?loc @@ E_application (a , b) +let e_binop ?loc name a b = Location.wrap ?loc @@ E_constant (name , [a ; b]) +let e_constant ?loc name lst = Location.wrap ?loc @@ E_constant (name , lst) +let e_look_up ?loc x y = Location.wrap ?loc @@ E_look_up (x , y) +let e_assign ?loc a b c = Location.wrap ?loc @@ E_assign (a , b , c) -let e_unit () : expression = E_literal (Literal_unit) -let e_int n : expression = E_literal (Literal_int n) -let e_nat n : expression = E_literal (Literal_nat n) -let e_bool b : expression = E_literal (Literal_bool b) -let e_string s : expression = E_literal (Literal_string s) -let e_address s : expression = E_literal (Literal_address s) -let e_tez s : expression = E_literal (Literal_tez s) -let e_bytes b : expression = E_literal (Literal_bytes (Bytes.of_string b)) -let e_record map : expression = E_record map -let e_tuple lst : expression = E_tuple lst -let e_some s : expression = E_constant ("SOME", [s]) -let e_none : expression = E_constant ("NONE", []) -let e_map_update k v old : expression = E_constant ("MAP_UPDATE" , [k ; v ; old]) -let e_map lst : expression = E_map lst -let e_list lst : expression = E_list lst -let e_pair a b : expression = E_tuple [a; b] -let e_constructor s a : expression = E_constructor (s , a) -let e_match a b : expression = E_matching (a , b) -let e_match_bool a b c : expression = e_match a (Match_bool {match_true = b ; match_false = c}) -let e_accessor a b = E_accessor (a , b) -let e_accessor_props a b = e_accessor a (List.map (fun x -> Access_record x) b) -let e_variable v = E_variable v -let e_failwith v = E_failwith v -let e_skip = E_skip -let e_loop cond body = E_loop (cond , body) -let e_sequence a b = E_sequence (a , b) -let e_let_in binder rhs result = E_let_in { binder ; rhs ; result } -let e_annotation expr ty = E_annotation (expr , ty) -let e_application a b = E_application (a , b) - -let e_binop name a b = E_constant (name , [a ; b]) - -let make_option_typed e t_opt = +let make_option_typed ?loc e t_opt = match t_opt with | None -> e - | Some t -> e_annotation e t + | Some t -> e_annotation ?loc e t -let ez_e_record lst = +let ez_e_record ?loc lst = let aux prev (k, v) = SMap.add k v prev in let map = List.fold_left aux SMap.empty lst in - e_record map + e_record ?loc map -let e_typed_none t_opt = +let e_typed_none ?loc t_opt = let type_annotation = t_option t_opt in - e_annotation e_none type_annotation + e_annotation ?loc (e_none ?loc ()) type_annotation -let e_typed_list lst t = - e_annotation (e_list lst) (t_list t) +let e_typed_list ?loc lst t = + e_annotation ?loc (e_list lst) (t_list t) -let e_map lst k v = e_annotation (e_map lst) (t_map k v) +let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v) -let e_lambda (binder : string) +let e_lambda ?loc (binder : string) (input_type : type_expression option) (output_type : type_expression option) (result : expression) : expression = - E_lambda { + Location.wrap ?loc @@ E_lambda { binder = (make_name binder , input_type) ; input_type = input_type ; output_type = output_type ; result ; } -let e_record (lst : (string * expr) list) : expression = - let aux prev (k, v) = SMap.add k v prev in - let map = List.fold_left aux SMap.empty lst in - E_record map +let e_record ?loc map = Location.wrap ?loc @@ E_record map + +let e_ez_record ?loc (lst : (string * expr) list) : expression = + let map = SMap.of_list lst in + e_record ?loc map let get_e_accessor = fun t -> match t with @@ -130,3 +133,10 @@ let get_e_list = fun t -> match t with | E_list lst -> ok lst | _ -> simple_fail "not a pair" + +let get_e_failwith = fun e -> + match Location.unwrap e with + | E_failwith fw -> ok fw + | _ -> simple_fail "not a failwith" + +let is_e_failwith e = to_bool @@ get_e_failwith e diff --git a/src/ast_simplified/misc.ml b/src/ast_simplified/misc.ml index 168a3f672..05b8e2601 100644 --- a/src/ast_simplified/misc.ml +++ b/src/ast_simplified/misc.ml @@ -35,7 +35,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b in trace (fun () -> error (thunk "not equal") error_content ()) @@ - match (a , b) with + match (Location.unwrap a , Location.unwrap b) with | E_literal a , E_literal b -> assert_literal_eq (a, b) | E_literal _ , _ -> @@ -113,8 +113,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = ) | E_list _, _ -> simple_fail "comparing list with other stuff" - | (E_annotation (a , _) , b) -> assert_value_eq (a , b) - | (a , E_annotation (b , _)) -> assert_value_eq (a , b) + | (E_annotation (a , _) , _b') -> assert_value_eq (a , b) + | (_a' , E_annotation (b , _)) -> assert_value_eq (a , b) | (E_variable _, _) | (E_lambda _, _) | (E_application _, _) | (E_let_in _, _) | (E_accessor _, _) diff --git a/src/ast_simplified/types.ml b/src/ast_simplified/types.ml index 6e47aa936..4693546b8 100644 --- a/src/ast_simplified/types.ml +++ b/src/ast_simplified/types.ml @@ -42,7 +42,7 @@ and let_in = { result : expr ; } -and expression = +and expression' = (* Base *) | E_literal of literal | E_constant of (name * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *) @@ -72,6 +72,8 @@ and expression = (* Annotate *) | E_annotation of expr * type_expression +and expression = expression' Location.wrap + and access = | Access_tuple of int | Access_record of string diff --git a/src/simplify/camligo.ml b/src/simplify/camligo.ml index 151116253..f32ffb86e 100644 --- a/src/simplify/camligo.ml +++ b/src/simplify/camligo.ml @@ -206,7 +206,7 @@ and ifthenelse let%bind cond' = bind_map_location expression cond in let%bind branch_true' = bind_map_location expression branch_true in let%bind branch_false' = bind_map_location expression branch_false in - ok @@ O.(e_match_bool (unwrap cond') (unwrap branch_true') (unwrap branch_false')) + ok @@ O.(e_matching_bool (unwrap cond') (unwrap branch_true') (unwrap branch_false')) and ifthen : (I.expression Location.wrap * I.expression Location.wrap) -> O.expression result @@ -214,7 +214,7 @@ and ifthen let (cond , branch_true) = it in let%bind cond' = bind_map_location expression cond in let%bind branch_true' = bind_map_location expression branch_true in - ok @@ O.(e_match_bool (unwrap cond') (unwrap branch_true') (e_unit ())) + ok @@ O.(e_matching_bool (unwrap cond') (unwrap branch_true') (e_unit ())) and match_ : I.expression Location.wrap * I.e_match_clause Location.wrap list -> O.expression result @@ -231,7 +231,7 @@ and match_ ok (x' , y') in bind_map_list aux clauses in let%bind matching = match_clauses clauses' in - ok O.(e_match expr' matching) + ok O.(e_matching expr' matching) and record = fun r -> @@ -244,7 +244,7 @@ and record in let%bind r' = bind_map_list (bind_map_location aux) r in let lst = List.map ((fun (x, y) -> unwrap x, unwrap y) >| unwrap) r' in - ok @@ O.(e_record lst) + ok @@ O.(e_ez_record lst) and expression_main : I.expression_main Location.wrap -> O.expression result = fun em -> let return x = ok @@ x in @@ -334,13 +334,13 @@ and expression_main : I.expression_main Location.wrap -> O.expression result = f and identifier_application : (string Location.wrap) list * string Location.wrap -> O.expression option -> _ result = fun (lst , v) param_opt -> let constant_name = String.concat "." ((List.map unwrap lst) @ [unwrap v]) in match List.assoc_opt constant_name constants , param_opt with - | Some s , None -> ok O.(E_constant (s , [])) + | Some s , None -> ok O.(e_constant s []) | Some s , Some param -> ( let params = - match param with + match Location.unwrap param with | E_tuple lst -> lst | _ -> [ param ] in - ok O.(E_constant (s , params)) + ok O.(e_constant s params) ) | None , param_opt -> ( let%bind () = diff --git a/src/simplify/pascaligo.ml b/src/simplify/pascaligo.ml index 038fd4484..c5af5e80c 100644 --- a/src/simplify/pascaligo.ml +++ b/src/simplify/pascaligo.ml @@ -16,16 +16,18 @@ let get_value : 'a Raw.reg -> 'a = fun x -> x.value open Operators.Simplify.Pascaligo +let r_split = Location.r_split + let return expr = ok @@ fun expr'_opt -> let expr = expr in match expr'_opt with | None -> ok @@ expr | Some expr' -> ok @@ e_sequence expr expr' -let return_let_in binder rhs = ok @@ fun expr'_opt -> +let return_let_in ?loc binder rhs = ok @@ fun expr'_opt -> match expr'_opt with | None -> simple_fail "missing return" (* Hard to explain. Shouldn't happen in prod. *) - | Some expr' -> ok @@ e_let_in binder rhs expr' + | Some expr' -> ok @@ e_let_in ?loc binder rhs expr' let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = match t with @@ -88,11 +90,12 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result let rec simpl_expression (t:Raw.expr) : expr result = let return x = ok x in - let simpl_projection = fun (p:Raw.projection) -> + let simpl_projection = fun (p : Raw.projection Region.reg) -> + let (p' , loc) = r_split p in let var = - let name = p.struct_name.value in + let name = p'.struct_name.value in e_variable name in - let path = p.field_path in + let path = p'.field_path in let path' = let aux (s:Raw.selection) = match s with @@ -100,97 +103,112 @@ let rec simpl_expression (t:Raw.expr) : expr result = | Component index -> Access_tuple (Z.to_int (snd index.value)) in List.map aux @@ npseq_to_list path in - return @@ E_accessor (var, path') + return @@ e_accessor ~loc var path' in match t with | EAnnot a -> ( - let (expr , type_expr) = a.value in + let ((expr , type_expr) , loc) = r_split a in let%bind expr' = simpl_expression expr in let%bind type_expr' = simpl_type_expression type_expr in - return @@ e_annotation expr' type_expr' + return @@ e_annotation ~loc expr' type_expr' ) | EVar c -> ( - let c' = c.value in + let (c' , loc) = r_split c in match List.assoc_opt c' constants with - | None -> return @@ E_variable c.value - | Some s -> return @@ E_constant (s , []) + | None -> return @@ e_variable ~loc c.value + | Some s -> return @@ e_constant ~loc s [] ) | ECall x -> ( - let (name, args) = x.value in - let f = name.value in - let args' = npseq_to_list args.value.inside in + let ((name, args) , loc) = r_split x in + let (f , f_loc) = r_split name in + let (args , args_loc) = r_split args in + let args' = npseq_to_list args.inside in match List.assoc_opt f constants with | None -> - let%bind arg = simpl_tuple_expression args' in - return @@ E_application (e_variable f, arg) + let%bind arg = simpl_tuple_expression ~loc:args_loc args' in + return @@ e_application ~loc (e_variable ~loc:f_loc f) arg | Some s -> let%bind lst = bind_map_list simpl_expression args' in - return @@ E_constant (s , lst) + return @@ e_constant ~loc s lst ) | EPar x -> simpl_expression x.value.inside - | EUnit _ -> return @@ E_literal Literal_unit - | EBytes x -> return @@ E_literal (Literal_bytes (Bytes.of_string @@ fst x.value)) + | EUnit reg -> + let loc = Location.lift reg in + return @@ e_literal ~loc Literal_unit + | EBytes x -> + let (x' , loc) = r_split x in + return @@ e_literal ~loc (Literal_bytes (Bytes.of_string @@ fst x')) | ETuple tpl -> let (Raw.TupleInj tpl') = tpl in - simpl_tuple_expression - @@ npseq_to_list tpl'.value.inside + let (tpl' , loc) = r_split tpl' in + simpl_tuple_expression ~loc @@ npseq_to_list tpl'.inside | ERecord r -> 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 (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ pseq_to_list r.value.elements in let aux prev (k, v) = SMap.add k v prev in - return @@ E_record (List.fold_left aux SMap.empty fields) - | EProj p' -> ( - let p = p'.value in - simpl_projection p + return @@ e_record (List.fold_left aux SMap.empty fields) + | EProj p -> simpl_projection p + | EConstr (ConstrApp c) -> ( + let ((c, args) , loc) = r_split c in + let (args , args_loc) = r_split args in + let%bind arg = + simpl_tuple_expression ~loc:args_loc + @@ npseq_to_list args.inside in + return @@ e_constructor ~loc c.value arg ) - | EConstr (ConstrApp c) -> - let (c, args) = c.value in - let%bind arg = - simpl_tuple_expression - @@ npseq_to_list args.value.inside in - return @@ E_constructor (c.value, arg) | EConstr (SomeApp a) -> - let (_, args) = a.value in + let ((_, args) , loc) = r_split a in + let (args , args_loc) = r_split args in let%bind arg = - simpl_tuple_expression - @@ npseq_to_list args.value.inside in - return @@ E_constant ("SOME", [arg]) - | EConstr (NoneExpr _) -> - return @@ E_constant ("NONE" , []) + simpl_tuple_expression ~loc:args_loc + @@ npseq_to_list args.inside in + return @@ e_constant ~loc "SOME" [arg] + | EConstr (NoneExpr reg) -> ( + let loc = Location.lift reg in + return @@ e_none ~loc () + ) | EArith (Add c) -> - simpl_binop "ADD" c.value + simpl_binop "ADD" c | EArith (Sub c) -> - simpl_binop "SUB" c.value + simpl_binop "SUB" c | EArith (Mult c) -> - simpl_binop "TIMES" c.value + simpl_binop "TIMES" c | EArith (Div c) -> - simpl_binop "DIV" c.value + simpl_binop "DIV" c | EArith (Mod c) -> - simpl_binop "MOD" c.value - | EArith (Int n) -> - let n = Z.to_int @@ snd @@ n.value in - return @@ E_literal (Literal_int n) - | EArith (Nat n) -> - let n = Z.to_int @@ snd @@ n.value in - return @@ E_literal (Literal_nat n) - | EArith (Mtz n) -> - let n = Z.to_int @@ snd @@ n.value in - return @@ E_literal (Literal_tez n) + simpl_binop "MOD" c + | EArith (Int n) -> ( + let (n , loc) = r_split n in + let n = Z.to_int @@ snd n in + return @@ e_literal ~loc (Literal_int n) + ) + | EArith (Nat n) -> ( + let (n , loc) = r_split n in + let n = Z.to_int @@ snd @@ n in + return @@ e_literal ~loc (Literal_nat n) + ) + | EArith (Mtz n) -> ( + let (n , loc) = r_split n in + let n = Z.to_int @@ snd @@ n in + return @@ e_literal ~loc (Literal_tez n) + ) | EArith _ -> simple_fail "arith: not supported yet" | EString (String s) -> + let (s , loc) = r_split s in let s' = - let s = s.value in + (* S contains quotes *) String.(sub s 1 ((length s) - 2)) in - return @@ E_literal (Literal_string s') + return @@ e_literal ~loc (Literal_string s') | EString _ -> simple_fail "string: not supported yet" | ELogic l -> simpl_logic_expression l | EList l -> simpl_list_expression l | ESet _ -> simple_fail "set: not supported yet" - | ECase c -> - let%bind e = simpl_expression c.value.expr in + | ECase c -> ( + let (c , loc) = r_split c in + let%bind e = simpl_expression c.expr in let%bind lst = let aux (x : Raw.expr Raw.case_clause) = let%bind expr = simpl_expression x.rhs in @@ -198,84 +216,103 @@ let rec simpl_expression (t:Raw.expr) : expr result = bind_list @@ List.map aux @@ List.map get_value - @@ npseq_to_list c.value.cases.value in + @@ npseq_to_list c.cases.value in let%bind cases = simpl_cases lst in - return @@ E_matching (e, cases) - | EMap (MapInj mi) -> + return @@ e_matching ~loc e cases + ) + | EMap (MapInj mi) -> ( + let (mi , loc) = r_split mi in let%bind lst = - let lst = List.map get_value @@ pseq_to_list mi.value.elements in + let lst = List.map get_value @@ pseq_to_list mi.elements in let aux : Raw.binding -> (expression * expression) result = fun b -> let%bind src = simpl_expression b.source in let%bind dst = simpl_expression b.image in ok (src, dst) in bind_map_list aux lst in - return (E_map lst) - | EMap (MapLookUp lu) -> - let%bind path = match lu.value.path with - | Name v -> return (E_variable v.value) - | Path p -> simpl_projection p.value + return @@ e_map ~loc lst + ) + | EMap (MapLookUp lu) -> ( + let (lu , loc) = r_split lu in + let%bind path = match lu.path with + | Name v -> ( + let (v , loc) = r_split v in + return @@ e_variable ~loc v + ) + | Path p -> simpl_projection p in - let%bind index = simpl_expression lu.value.index.value.inside in - return (E_look_up (path, index)) + let%bind index = simpl_expression lu.index.value.inside in + return @@ e_look_up ~loc path index + ) and simpl_logic_expression (t:Raw.logic_expr) : expression result = let return x = ok x in match t with - | BoolExpr (False _) -> - return @@ E_literal (Literal_bool false) - | BoolExpr (True _) -> - return @@ E_literal (Literal_bool true) + | BoolExpr (False reg) -> ( + let loc = Location.lift reg in + return @@ e_literal ~loc (Literal_bool false) + ) + | BoolExpr (True reg) -> ( + let loc = Location.lift reg in + return @@ e_literal ~loc (Literal_bool true) + ) | BoolExpr (Or b) -> - simpl_binop "OR" b.value + simpl_binop "OR" b | BoolExpr (And b) -> - simpl_binop "AND" b.value + simpl_binop "AND" b | BoolExpr (Not b) -> - simpl_unop "NOT" b.value + simpl_unop "NOT" b | CompExpr (Lt c) -> - simpl_binop "LT" c.value + simpl_binop "LT" c | CompExpr (Gt c) -> - simpl_binop "GT" c.value + simpl_binop "GT" c | CompExpr (Leq c) -> - simpl_binop "LE" c.value + simpl_binop "LE" c | CompExpr (Geq c) -> - simpl_binop "GE" c.value + simpl_binop "GE" c | CompExpr (Equal c) -> - simpl_binop "EQ" c.value + simpl_binop "EQ" c | CompExpr (Neq c) -> - simpl_binop "NEQ" c.value + simpl_binop "NEQ" c and simpl_list_expression (t:Raw.list_expr) : expression result = let return x = ok x in match t with | Cons c -> - simpl_binop "CONS" c.value - | List lst -> + simpl_binop "CONS" c + | List lst -> ( + let (lst , loc) = r_split lst in let%bind lst' = bind_map_list simpl_expression @@ - pseq_to_list lst.value.elements in - return @@ E_list lst' - | Nil _ -> - return @@ E_list [] + pseq_to_list lst.elements in + return @@ e_list ~loc lst' + ) + | Nil reg -> ( + let loc = Location.lift reg in + return @@ e_list ~loc [] + ) -and simpl_binop (name:string) (t:_ Raw.bin_op) : expression result = +and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = let return x = ok x in + let (t , loc) = r_split t in let%bind a = simpl_expression t.arg1 in let%bind b = simpl_expression t.arg2 in - return @@ E_constant (name, [a;b]) + return @@ e_constant ~loc name [ a ; b ] -and simpl_unop (name:string) (t:_ Raw.un_op) : expression result = +and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = let return x = ok x in + let (t , loc) = r_split t in let%bind a = simpl_expression t.arg in - return @@ E_constant (name, [a]) + return @@ e_constant ~loc name [ a ] -and simpl_tuple_expression (lst:Raw.expr list) : expression result = +and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = let return x = ok x in match lst with - | [] -> return @@ E_literal Literal_unit + | [] -> return @@ e_literal Literal_unit | [hd] -> simpl_expression hd - | lst -> + | lst -> ( let%bind lst = bind_list @@ List.map simpl_expression lst in - return @@ E_tuple lst + return @@ e_tuple ?loc lst + ) and simpl_local_declaration : Raw.local_decl -> _ result = fun t -> match t with @@ -284,26 +321,28 @@ and simpl_local_declaration : Raw.local_decl -> _ result = fun t -> and simpl_lambda_declaration : Raw.lambda_decl -> _ result = fun l -> match l with - | FunDecl f -> - let%bind (name , e) = simpl_fun_declaration (f.value) in - return_let_in name e + | FunDecl f -> ( + let (f , loc) = r_split f in + let%bind (name , e) = simpl_fun_declaration ~loc f in + return_let_in ~loc name e + ) | ProcDecl _ -> simple_fail "no local procedure yet" | EntryDecl _ -> simple_fail "no local entry-point yet" and simpl_data_declaration : Raw.data_decl -> _ result = fun t -> match t with | LocalVar x -> - let x = x.value in + let (x , loc) = r_split x in let name = x.name.value in let%bind t = simpl_type_expression x.var_type in let%bind expression = simpl_expression x.init in - return_let_in (name , Some t) expression + return_let_in ~loc (name , Some t) expression | LocalConst x -> - let x = x.value in + let (x , loc) = r_split x in let name = x.name.value in let%bind t = simpl_type_expression x.const_type in let%bind expression = simpl_expression x.init in - return_let_in (name , Some t) expression + return_let_in ~loc (name , Some t) expression and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t -> match t with @@ -318,7 +357,7 @@ and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t let%bind type_expression = simpl_type_expression c.param_type in ok (type_name , type_expression) -and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * expression) result = fun x -> +and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression option) * expression) result = fun ~loc x -> let open! Raw in let {name;param;ret_type;local_decls;block;return} : fun_decl = x in (match npseq_to_list param.value.inside with @@ -338,12 +377,8 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e let%bind result = let aux prec cur = cur (Some prec) in bind_fold_right_list aux result body in - let expression = E_lambda { - binder = (binder , Some input_type) ; - input_type = Some input_type ; - output_type = Some output_type ; - result - } in + let expression : expression = e_lambda ~loc binder (Some input_type) + (Some output_type) result in let type_annotation = Some (T_function (input_type, output_type)) in ok ((name , type_annotation) , expression) ) @@ -355,7 +390,7 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e (arguments_name , type_expression) in let%bind tpl_declarations = let aux = fun i x -> - let expr = E_accessor (E_variable arguments_name , [ Access_tuple i ]) in + let expr = e_accessor (e_variable arguments_name) [ Access_tuple i ] in let type_ = Some (snd x) in let ass = return_let_in (fst x , type_) expr in ass @@ -372,24 +407,20 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e let%bind result = let aux prec cur = cur (Some prec) in bind_fold_right_list aux result body in - let expression = E_lambda { - binder = (binder , Some input_type) ; - input_type = Some input_type ; - output_type = Some output_type ; - result - } in + let expression = e_lambda ~loc binder (Some input_type) (Some output_type) result in let type_annotation = Some (T_function (input_type, output_type)) in ok ((name.value , type_annotation) , expression) ) ) and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t -> let open! Raw in - let loc : 'a . 'a Raw.reg -> _ -> _ = fun x v -> Location.wrap ~loc:(File x.region) v in match t with - | TypeDecl x -> - let {name;type_expr} : Raw.type_decl = x.value in + | TypeDecl x -> ( + let (x , loc) = r_split x in + let {name;type_expr} : Raw.type_decl = x in let%bind type_expression = simpl_type_expression type_expr in - ok @@ loc x @@ Declaration_type (name.value , type_expression) + ok @@ Location.wrap ~loc (Declaration_type (name.value , type_expression)) + ) | ConstDecl x -> let simpl_const_decl = fun {name;const_type;init} -> let%bind expression = simpl_expression init in @@ -398,11 +429,11 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu ok @@ Declaration_constant (name.value , type_annotation , expression) in bind_map_location simpl_const_decl (Location.lift_region x) - | LambdaDecl (FunDecl x) -> - let aux f x = - let%bind ((name , ty_opt) , expr) = f x in - ok @@ Declaration_constant (name , ty_opt , expr) in - bind_map_location (aux simpl_fun_declaration) (Location.lift_region x) + | LambdaDecl (FunDecl x) -> ( + let (x , loc) = r_split x in + let%bind ((name , ty_opt) , expr) = simpl_fun_declaration ~loc x in + ok @@ Location.wrap ~loc (Declaration_constant (name , ty_opt , expr)) + ) | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet" | LambdaDecl (EntryDecl _)-> simple_fail "no entry point yet" @@ -418,7 +449,10 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu let%bind expr = simpl_expression e.value.fail_expr in return @@ e_failwith expr ) - | Skip _ -> return @@ e_skip + | Skip reg -> ( + let loc = Location.lift reg in + return @@ e_skip ~loc () + ) | Loop (While l) -> let l = l.value in let%bind cond = simpl_expression l.cond in @@ -427,8 +461,8 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu return @@ e_loop cond body | Loop (For _) -> simple_fail "no for yet" - | Cond c -> - let c = c.value in + | Cond c -> ( + let (c , loc) = r_split c in let%bind expr = simpl_expression c.test in let%bind match_true = match c.ifso with | ClauseInstr i -> simpl_instruction_block i @@ -438,9 +472,10 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu | ClauseBlock b -> simpl_statements @@ fst b.value.inside in let%bind match_true = match_true None in let%bind match_false = match_false None in - return @@ E_matching (expr, (Match_bool {match_true; match_false})) + return @@ e_matching expr ~loc (Match_bool {match_true; match_false}) + ) | Assign a -> ( - let a = a.value in + let (a , loc) = r_split a in let%bind value_expr = match a.rhs with | Expr e -> simpl_expression e | NoneExpr _ -> simple_fail "no none assignments yet" @@ -448,7 +483,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu match a.lhs with | Path path -> ( let (name , path') = simpl_path path in - return @@ E_assign (name , path' , value_expr) + return @@ e_assign ~loc name path' value_expr ) | MapPath v -> ( let v' = v.value in @@ -458,11 +493,11 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu let%bind key_expr = simpl_expression v'.index.value.inside in let old_expr = e_variable name.value in let expr' = e_map_update key_expr value_expr old_expr in - return @@ E_assign (name.value , [] , expr') + return @@ e_assign ~loc name.value [] expr' ) ) | CaseInstr c -> ( - let c = c.value in + let (c , loc) = r_split c in let%bind expr = simpl_expression c.expr in let%bind cases = let aux (x : Raw.instruction Raw.case_clause Raw.reg) = @@ -473,25 +508,25 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu @@ List.map aux @@ npseq_to_list c.cases.value in let%bind m = simpl_cases cases in - return @@ E_matching (expr, m) + return @@ e_matching ~loc expr m ) | RecordPatch r -> ( let r = r.value in let (name , access_path) = simpl_path r.path in let%bind inj = bind_list - @@ List.map (fun (x:Raw.field_assign) -> let%bind e = simpl_expression x.field_expr in ok (x.field_name.value, e)) - @@ List.map (fun (x:_ Raw.reg) -> x.value) + @@ List.map (fun (x:Raw.field_assign Region.reg) -> + let (x , loc) = r_split x in + let%bind e = simpl_expression x.field_expr in ok (x.field_name.value, e , loc) + ) @@ pseq_to_list r.record_inj.value.elements in let%bind expr = - let aux = fun (access , v) -> - E_assign (name , access_path @ [ Access_record access ] , v) in + let aux = fun (access , v , loc) -> + e_assign ~loc name (access_path @ [ Access_record access ]) v in let assigns = List.map aux inj in match assigns with | [] -> simple_fail "empty record patch" | hd :: tl -> ( - let aux acc cur = - e_sequence (acc) (cur) - in + let aux acc cur = e_sequence (acc) (cur) in ok @@ List.fold_left aux hd tl ) in @@ -499,15 +534,16 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu ) | MapPatch _ -> simple_fail "no map patch yet" | SetPatch _ -> simple_fail "no set patch yet" - | MapRemove r -> - let v = r.value in + | MapRemove r -> ( + let (v , loc) = r_split r in let key = v.key in let%bind map = match v.map with | Name v -> ok v.value | _ -> simple_fail "no complex map remove yet" in let%bind key' = simpl_expression key in - let expr = E_constant ("MAP_REMOVE", [key' ; e_variable map]) in - return @@ E_assign (map , [] , expr) + let expr = e_constant ~loc "MAP_REMOVE" [key' ; e_variable map] in + return @@ e_assign ~loc map [] expr + ) | SetRemove _ -> simple_fail "no set remove yet" and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p -> diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 70b1df25f..5d6367901 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -210,7 +210,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a let content () = Format.asprintf "Expression: %a\nLog: %s\n" I.PP.expression ae (L.get()) in error title content in trace main_error @@ - match ae with + match Location.unwrap ae with (* Basic *) | E_failwith _ -> simple_fail "can't type failwith in isolation" | E_variable name -> @@ -394,7 +394,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a let%bind ex' = type_expression e ex in match m with (* Special case for assert-like failwiths. TODO: CLEAN THIS. *) - | I.Match_bool { match_false ; match_true = E_failwith fw } -> ( + | I.Match_bool { match_false ; match_true } when I.is_e_failwith match_true -> ( + let%bind fw = I.get_e_failwith match_true in let%bind fw' = type_expression e fw in let%bind mf' = type_expression e match_false in let%bind () = @@ -526,55 +527,54 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = match e.expression with | E_literal l -> let%bind l = untype_literal l in - return (E_literal l) + return (e_literal l) | E_constant (n, lst) -> - let%bind lst' = bind_list - @@ List.map untype_expression lst in - return (E_constant (n, lst')) + let%bind lst' = bind_map_list untype_expression lst in + return (e_constant n lst') | E_variable n -> - return (E_variable n) + return (e_variable n) | E_application (f, arg) -> let%bind f' = untype_expression f in let%bind arg' = untype_expression arg in - return (E_application (f', arg')) + return (e_application f' arg') | E_lambda {binder;input_type;output_type;result} -> let%bind input_type = untype_type_value input_type in let%bind output_type = untype_type_value output_type in let%bind result = untype_expression result in - return (E_lambda {binder = (binder , Some input_type);input_type = Some input_type;output_type = Some output_type;result}) + return (e_lambda binder (Some input_type) (Some output_type) result) | E_tuple lst -> let%bind lst' = bind_list @@ List.map untype_expression lst in - return (E_tuple lst') + return (e_tuple lst') | E_tuple_accessor (tpl, ind) -> let%bind tpl' = untype_expression tpl in - return (E_accessor (tpl', [Access_tuple ind])) + return (e_accessor tpl' [Access_tuple ind]) | E_constructor (n, p) -> let%bind p' = untype_expression p in - return (E_constructor (n, p')) + return (e_constructor n p') | E_record r -> let%bind r' = bind_smap @@ SMap.map untype_expression r in - return (E_record r') + return (e_record r') | E_record_accessor (r, s) -> let%bind r' = untype_expression r in - return (E_accessor (r', [Access_record s])) + return (e_accessor r' [Access_record s]) | E_map m -> let%bind m' = bind_map_list (bind_map_pair untype_expression) m in - return (E_map m') + return (e_map m') | E_list lst -> let%bind lst' = bind_map_list untype_expression lst in - return (E_list lst') + return (e_list lst') | E_look_up dsi -> - let%bind dsi' = bind_map_pair untype_expression dsi in - return (E_look_up dsi') + let%bind (a , b) = bind_map_pair untype_expression dsi in + return (e_look_up a b) | E_matching (ae, m) -> let%bind ae' = untype_expression ae in let%bind m' = untype_matching untype_expression m in - return (E_matching (ae', m')) + return (e_matching ae' m') | E_failwith ae -> let%bind ae' = untype_expression ae in - return (E_failwith ae') + return (e_failwith ae') | E_sequence _ | E_loop _ | E_assign _ -> simple_fail "not possible to untranspile statements yet" @@ -582,7 +582,7 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = let%bind tv = untype_type_value rhs.type_annotation in let%bind rhs = untype_expression rhs in let%bind result = untype_expression result in - return (E_let_in {binder = (binder , Some tv);rhs;result}) + return (e_let_in (binder , (Some tv)) rhs result) and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m -> let open I in diff --git a/vendors/ligo-utils/simple-utils/location.ml b/vendors/ligo-utils/simple-utils/location.ml index d8a945000..a710e1185 100644 --- a/vendors/ligo-utils/simple-utils/location.ml +++ b/vendors/ligo-utils/simple-utils/location.ml @@ -22,16 +22,21 @@ let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = let virtual_location s = Virtual s let dummy = virtual_location "dummy" +let generated = virtual_location "generated" type 'a wrap = { wrap_content : 'a ; location : t ; } -let wrap ~loc wrap_content = { wrap_content ; location = loc } +let wrap ?(loc = generated) wrap_content = { wrap_content ; location = loc } let unwrap { wrap_content ; _ } = wrap_content let map f x = { x with wrap_content = f x.wrap_content } let pp_wrap f ppf { wrap_content ; _ } = Format.fprintf ppf "%a" f wrap_content let lift_region : 'a Region.reg -> 'a wrap = fun x -> wrap ~loc:(File x.region) x.value +let lift : Region.region -> t = fun x -> File x + +let r_extract : 'a Region.reg -> t = fun x -> File x.region +let r_split : 'a Region.reg -> ('a * t) = fun x -> x.value , File x.region From 5b42d72e41fa7bebbd51a8af9a20d338aa7cc430 Mon Sep 17 00:00:00 2001 From: Galfour Date: Tue, 28 May 2019 16:34:53 +0000 Subject: [PATCH 2/8] propagate source code locations from ligodity --- src/simplify/ligodity.ml | 310 +++++++++++++++++++--------------- src/test/coase_tests.ml | 8 +- src/test/integration_tests.ml | 2 +- 3 files changed, 179 insertions(+), 141 deletions(-) diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index 0c3398758..0e51b6f9f 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -19,6 +19,8 @@ let get_value : 'a Raw.reg -> 'a = fun x -> x.value open Operators.Simplify.Ligodity +let r_split = Location.r_split + let rec simpl_type_expression : Raw.type_expr -> type_expression result = function | TPar x -> simpl_type_expression x.value.inside @@ -79,9 +81,10 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result ok @@ T_tuple lst let rec simpl_expression : - ?te_annot:type_expression -> Raw.expr -> expr result = fun ?te_annot t -> - let return x = ok @@ make_option_typed x te_annot in - let simpl_projection = fun (p:Raw.projection) -> + Raw.expr -> expr result = fun t -> + let return x = ok x in + let simpl_projection = fun (p:Raw.projection Region.reg) -> + let (p , loc) = r_split p in let var = let name = p.struct_name.value in e_variable name in @@ -95,107 +98,127 @@ let rec simpl_expression : Access_tuple (Z.to_int (snd index.value)) in List.map aux @@ npseq_to_list path in - return @@ E_accessor (var, path') + return @@ e_accessor ~loc var path' in - let mk_let_in binder rhs result = - E_let_in {binder; rhs; result} in match t with | Raw.ELetIn e -> ( - let Raw.{binding; body; _} = e.value in - let Raw.{variable; lhs_type; let_rhs; _} = binding in - let%bind type_annotation = bind_map_option - (fun (_,type_expr) -> simpl_type_expression type_expr) + let Raw.{binding ; body ; _} = e.value in + let Raw.{variable ; lhs_type ; let_rhs ; _} = binding in + let%bind ty_opt = + bind_map_option + (fun (_ , type_expr) -> simpl_type_expression type_expr) lhs_type in - let%bind rhs = simpl_expression ?te_annot:type_annotation let_rhs in + let%bind rhs = simpl_expression let_rhs in + let rhs' = + match ty_opt with + | None -> rhs + | Some ty -> e_annotation rhs ty in let%bind body = simpl_expression body in - return @@ mk_let_in (variable.value , None) rhs body + return @@ e_let_in (variable.value , None) rhs' body ) | Raw.EAnnot a -> ( - let (expr , type_expr) = a.value in - match te_annot with - | None -> ( - let%bind te_annot = simpl_type_expression type_expr in - let%bind expr' = simpl_expression ~te_annot expr in - ok expr' - ) - | Some _ -> simple_fail "no double annotation" + let (a , loc) = r_split a in + let (expr , type_expr) = a in + let%bind expr' = simpl_expression expr in + let%bind type_expr' = simpl_type_expression type_expr in + return @@ e_annotation ~loc expr' type_expr' ) | EVar c -> ( let c' = c.value in match List.assoc_opt c' constants with - | None -> return @@ E_variable c.value - | Some s -> return @@ E_constant (s , []) + | None -> return @@ e_variable c.value + | Some s -> return @@ e_constant s [] ) | ECall x -> ( - let (e1, e2) = x.value in + let ((e1 , e2) , loc) = r_split x in let%bind args = bind_map_list simpl_expression (nseq_to_list e2) in match e1 with - | EVar f -> - (match List.assoc_opt f.value constants with - | None -> + | EVar f -> ( + let (f , f_loc) = r_split f in + match List.assoc_opt f constants with + | None -> ( let%bind arg = simpl_tuple_expression (nseq_to_list e2) in - return @@ E_application (e_variable f.value, arg) - | Some s -> return @@ E_constant (s , args)) - | e1 -> - let%bind e1' = simpl_expression e1 in - let%bind arg = simpl_tuple_expression (nseq_to_list e2) in - return @@ E_application (e1' , arg) + return @@ e_application ~loc (e_variable ~loc:f_loc f) arg + ) + | Some s -> return @@ e_constant ~loc s args + ) + | e1 -> ( + let%bind e1' = simpl_expression e1 in + let%bind arg = simpl_tuple_expression (nseq_to_list e2) in + return @@ e_application ~loc e1' arg + ) ) - | EPar x -> simpl_expression ?te_annot x.value.inside - | EUnit _ -> return @@ E_literal Literal_unit - | EBytes x -> return @@ E_literal (Literal_bytes (Bytes.of_string @@ fst x.value)) - | ETuple tpl -> simpl_tuple_expression ?te_annot @@ (npseq_to_list tpl.value) - | ERecord r -> + | EPar x -> simpl_expression x.value.inside + | EUnit reg -> ( + let (_ , loc) = r_split reg in + return @@ e_literal ~loc Literal_unit + ) + | EBytes x -> ( + let (x , loc) = r_split x in + return @@ e_literal ~loc (Literal_bytes (Bytes.of_string @@ fst x)) + ) + | ETuple tpl -> simpl_tuple_expression @@ (npseq_to_list tpl.value) + | ERecord r -> ( + let (r , loc) = r_split r in 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 (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) - @@ pseq_to_list r.value.elements in - let aux prev (k, v) = SMap.add k v prev in - return @@ E_record (List.fold_left aux SMap.empty fields) - | EProj p' -> ( - let p = p'.value in - simpl_projection p + @@ pseq_to_list r.elements in + let map = SMap.of_list fields in + return @@ e_record ~loc map ) - | EConstr c -> - let (c, args) = c.value in + | EProj p -> simpl_projection p + | EConstr c -> ( + let ((c_name , args) , loc) = r_split c in + let (c_name , _c_loc) = r_split c_name in let args = match args with None -> [] | Some arg -> [arg] in let%bind arg = simpl_tuple_expression @@ args in - return @@ E_constructor (c.value, arg) + return @@ e_constructor ~loc c_name arg + ) | EArith (Add c) -> - simpl_binop ?te_annot "ADD" c.value + simpl_binop "ADD" c | EArith (Sub c) -> - simpl_binop ?te_annot "SUB" c.value + simpl_binop "SUB" c | EArith (Mult c) -> - simpl_binop ?te_annot "TIMES" c.value + simpl_binop "TIMES" c | EArith (Div c) -> - simpl_binop ?te_annot "DIV" c.value + simpl_binop "DIV" c | EArith (Mod c) -> - simpl_binop ?te_annot "MOD" c.value - | EArith (Int n) -> - let n = Z.to_int @@ snd @@ n.value in - return @@ E_literal (Literal_int n) - | EArith (Nat n) -> - let n = Z.to_int @@ snd @@ n.value in - return @@ E_literal (Literal_nat n) - | EArith (Mtz n) -> - let n = Z.to_int @@ snd @@ n.value in - return @@ E_literal (Literal_tez n) + simpl_binop "MOD" c + | EArith (Int n) -> ( + let (n , loc) = r_split n in + let n = Z.to_int @@ snd @@ n in + return @@ e_literal ~loc (Literal_int n) + ) + | EArith (Nat n) -> ( + let (n , loc) = r_split n in + let n = Z.to_int @@ snd @@ n in + return @@ e_literal ~loc (Literal_nat n) + ) + | EArith (Mtz n) -> ( + let (n , loc) = r_split n in + let n = Z.to_int @@ snd @@ n in + return @@ e_literal ~loc (Literal_tez n) + ) | EArith _ -> simple_fail "arith: not supported yet" - | EString (String s) -> + | EString (String s) -> ( + let (s , loc) = r_split s in let s' = - let s = s.value in + let s = s in String.(sub s 1 ((length s) - 2)) in - return @@ E_literal (Literal_string s') + return @@ e_literal ~loc (Literal_string s') + ) | EString _ -> simple_fail "string: not supported yet" - | ELogic l -> simpl_logic_expression ?te_annot l - | EList l -> simpl_list_expression ?te_annot l - | ECase c -> - let%bind e = simpl_expression c.value.expr in + | ELogic l -> simpl_logic_expression l + | EList l -> simpl_list_expression l + | ECase c -> ( + let (c , loc) = r_split c in + let%bind e = simpl_expression c.expr in let%bind lst = let aux (x : Raw.expr Raw.case_clause) = let%bind expr = simpl_expression x.rhs in @@ -203,96 +226,111 @@ let rec simpl_expression : bind_list @@ List.map aux @@ List.map get_value - @@ npseq_to_list c.value.cases.value in + @@ npseq_to_list c.cases.value in let%bind cases = simpl_cases lst in - return @@ E_matching (e, cases) - | EFun lamb -> + return @@ e_matching ~loc e cases + ) + | EFun lamb -> ( + let (lamb , loc) = r_split lamb in let%bind input_type = bind_map_option (fun (_,type_expr) -> simpl_type_expression type_expr) - lamb.value.p_annot in + lamb.p_annot in let body, body_type = - match lamb.value.body with - EAnnot {value = expr, type_expr} -> expr, Some type_expr + match lamb.body with + | EAnnot {value = expr, type_expr} -> expr, Some type_expr | expr -> expr, None in let%bind output_type = bind_map_option simpl_type_expression body_type in let%bind result = simpl_expression body in - let binder = lamb.value.param.value, input_type in - let lambda = {binder; input_type; output_type; result = result} - in return @@ E_lambda lambda - | ESeq s -> - let items : Raw.expr list = pseq_to_list s.value.elements in - (match items with - [] -> return @@ E_skip - | expr::more -> - let expr' = simpl_expression expr in - let apply (e1: Raw.expr) (e2: expression Trace.result) = - let%bind a = simpl_expression e1 in - let%bind e2' = e2 in - return @@ E_sequence (a, e2') - in List.fold_right apply more expr') - | ECond c -> - let c = c.value in + let binder = lamb.param.value in + return @@ e_lambda ~loc binder input_type output_type result + ) + | ESeq s -> ( + let (s , loc) = r_split s in + let items : Raw.expr list = pseq_to_list s.elements in + match items with + | [] -> return @@ e_skip ~loc () + | expr :: more -> ( + let expr' = simpl_expression expr in + let apply (e1: Raw.expr) (e2: expression Trace.result) = + let%bind a = simpl_expression e1 in + let%bind e2' = e2 in + return @@ e_sequence ~loc a e2' + in List.fold_right apply more expr' + ) + ) + | ECond c -> ( + let (c , loc) = r_split c in let%bind expr = simpl_expression c.test in let%bind match_true = simpl_expression c.ifso in let%bind match_false = simpl_expression c.ifnot in - return @@ E_matching (expr, (Match_bool {match_true; match_false})) -and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = - let return x = ok @@ make_option_typed x te_annot in - match t with - | BoolExpr (False _) -> - return @@ E_literal (Literal_bool false) - | BoolExpr (True _) -> - return @@ E_literal (Literal_bool true) - | BoolExpr (Or b) -> - simpl_binop ?te_annot "OR" b.value - | BoolExpr (And b) -> - simpl_binop ?te_annot "AND" b.value - | BoolExpr (Not b) -> - simpl_unop ?te_annot "NOT" b.value - | CompExpr (Lt c) -> - simpl_binop ?te_annot "LT" c.value - | CompExpr (Gt c) -> - simpl_binop ?te_annot "GT" c.value - | CompExpr (Leq c) -> - simpl_binop ?te_annot "LE" c.value - | CompExpr (Geq c) -> - simpl_binop ?te_annot "GE" c.value - | CompExpr (Equal c) -> - simpl_binop ?te_annot "EQ" c.value - | CompExpr (Neq c) -> - simpl_binop ?te_annot "NEQ" c.value + let match_bool = Match_bool { match_true ; match_false } in + return @@ e_matching ~loc expr match_bool + ) -and simpl_list_expression ?te_annot (t:Raw.list_expr) : expression result = - let return x = ok @@ make_option_typed x te_annot in +and simpl_logic_expression (t:Raw.logic_expr) : expr result = + let return x = ok @@ x in match t with - | Cons c -> - simpl_binop ?te_annot "CONS" c.value - | List lst -> + | BoolExpr (False reg) -> ( + let loc = Location.lift reg in + return @@ e_literal ~loc (Literal_bool false) + ) + | BoolExpr (True reg) -> ( + let loc = Location.lift reg in + return @@ e_literal ~loc (Literal_bool true) + ) + | BoolExpr (Or b) -> + simpl_binop "OR" b + | BoolExpr (And b) -> + simpl_binop "AND" b + | BoolExpr (Not b) -> + simpl_unop "NOT" b + | CompExpr (Lt c) -> + simpl_binop "LT" c + | CompExpr (Gt c) -> + simpl_binop "GT" c + | CompExpr (Leq c) -> + simpl_binop "LE" c + | CompExpr (Geq c) -> + simpl_binop "GE" c + | CompExpr (Equal c) -> + simpl_binop "EQ" c + | CompExpr (Neq c) -> + simpl_binop "NEQ" c + +and simpl_list_expression (t:Raw.list_expr) : expression result = + let return x = ok @@ x in + match t with + | Cons c -> simpl_binop "CONS" c + | List lst -> ( + let (lst , loc) = r_split lst in let%bind lst' = bind_map_list simpl_expression @@ - pseq_to_list lst.value.elements in - return @@ E_list lst' + pseq_to_list lst.elements in + return @@ e_list ~loc lst' + ) -and simpl_binop ?te_annot (name:string) (t:_ Raw.bin_op) : expression result = - let return x = ok @@ make_option_typed x te_annot in - let%bind a = simpl_expression t.arg1 in - let%bind b = simpl_expression t.arg2 in - return @@ E_constant (name, [a;b]) +and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = + let return x = ok @@ x in + let (args , loc) = r_split t in + let%bind a = simpl_expression args.arg1 in + let%bind b = simpl_expression args.arg2 in + return @@ e_constant ~loc name [ a ; b ] -and simpl_unop ?te_annot (name:string) (t:_ Raw.un_op) : expression result = - let return x = ok @@ make_option_typed x te_annot in +and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = + let return x = ok @@ x in + let (t , loc) = r_split t in let%bind a = simpl_expression t.arg in - return @@ E_constant (name, [a]) + return @@ e_constant ~loc name [ a ] -and simpl_tuple_expression ?te_annot (lst:Raw.expr list) : expression result = - let return x = ok @@ make_option_typed x te_annot in +and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = + let return x = ok @@ x in match lst with - | [] -> return @@ E_literal Literal_unit - | [hd] -> simpl_expression ?te_annot hd + | [] -> return @@ e_literal ?loc Literal_unit + | [hd] -> simpl_expression hd | lst -> let%bind lst = bind_list @@ List.map simpl_expression lst in - return @@ E_tuple lst + return @@ e_tuple ?loc lst and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t -> let open! Raw in @@ -309,7 +347,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu let%bind type_annotation = bind_map_option (fun (_,type_expr) -> simpl_type_expression type_expr) lhs_type in - let%bind rhs = simpl_expression ?te_annot:type_annotation let_rhs in + let%bind rhs = simpl_expression let_rhs in let name = variable.value in ok @@ loc x @@ (Declaration_constant (name , type_annotation , rhs)) ) diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index 4d15754db..8f3ef0e26 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -31,7 +31,7 @@ let card_ez owner = card (e_address owner) let make_cards assoc_lst = let card_id_ty = t_nat in - e_map assoc_lst card_id_ty card_ty + e_typed_map assoc_lst card_id_ty card_ty let card_pattern (coeff , qtt) = ez_e_record [ @@ -51,7 +51,7 @@ let card_pattern_ez (coeff , qtt) = let make_card_patterns lst = let card_pattern_id_ty = t_nat in let assoc_lst = List.mapi (fun i x -> (e_nat i , x)) lst in - e_map assoc_lst card_pattern_id_ty card_pattern_ty + e_typed_map assoc_lst card_pattern_id_ty card_pattern_ty let storage cards_patterns cards next_id = ez_e_record [ @@ -208,9 +208,9 @@ let sell () = e_pair sell_action storage in let make_expecter : int -> expression -> unit result = fun n result -> - let%bind (ops , storage) = get_e_pair result in + let%bind (ops , storage) = get_e_pair @@ Location.unwrap result in let%bind () = - let%bind lst = get_e_list ops in + let%bind lst = get_e_list @@ Location.unwrap ops in Assert.assert_list_size lst 1 in let expected_storage = let cards = List.hds @@ cards_ez first_owner n in diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index ccbf6e893..5cfec5068 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -249,7 +249,7 @@ let map () : unit result = let ez lst = let open Ast_simplified.Combinators in let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in - e_map lst' t_int t_int + e_typed_map lst' t_int t_int in let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in From 79af0abab33d13efe82cf78820e6c09441fda037 Mon Sep 17 00:00:00 2001 From: Galfour Date: Tue, 28 May 2019 17:02:40 +0000 Subject: [PATCH 3/8] propagate source-code locations to ast_typed --- src/ast_typed/combinators.ml | 8 +++++++- src/ast_typed/types.ml | 11 ++++++----- src/typer/typer.ml | 3 ++- vendors/ligo-utils/simple-utils/location.ml | 1 + 4 files changed, 16 insertions(+), 7 deletions(-) diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index ce3c6902c..f5859806e 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -2,7 +2,13 @@ open Trace open Types let make_t type_value' simplified = { type_value' ; simplified } -let make_a_e expression type_annotation environment = { expression ; type_annotation ; dummy_field = () ; environment } +let make_a_e ?(location = Location.generated) expression type_annotation environment = { + expression ; + type_annotation ; + dummy_field = () ; + environment ; + location ; +} let make_n_e name a_e = { name ; annotated_expression = a_e } let make_n_t type_name type_value = { type_name ; type_value } diff --git a/src/ast_typed/types.ml b/src/ast_typed/types.ml index 9dbd2fc64..a1bfd46d3 100644 --- a/src/ast_typed/types.ml +++ b/src/ast_typed/types.ml @@ -34,10 +34,11 @@ and small_environment = (environment * type_environment) and full_environment = small_environment List.Ne.t and annotated_expression = { - expression: expression ; - type_annotation: tv ; - environment: full_environment ; - dummy_field: unit ; + expression : expression ; + type_annotation : tv ; + environment : full_environment ; + location : Location.t ; + dummy_field : unit ; } and named_expression = { @@ -162,6 +163,6 @@ let get_entry (p:program) (entry : string) : annotated_expression result = let get_functional_entry (p:program) (entry : string) : (lambda * type_value) result = let%bind entry = get_entry p entry in match entry.expression with - | E_lambda l -> ok (l, entry.type_annotation) + | E_lambda l -> ok (l , entry.type_annotation) | _ -> simple_fail "given entry point is not functional" diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 5d6367901..6e55604cc 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -204,7 +204,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a match tv_opt with | None -> ok () | Some tv' -> O.assert_type_value_eq (tv' , tv) in - ok @@ make_a_e expr tv e in + let location = Location.get_location ae in + ok @@ make_a_e ~location expr tv e in let main_error = let title () = "typing expression" in let content () = Format.asprintf "Expression: %a\nLog: %s\n" I.PP.expression ae (L.get()) in diff --git a/vendors/ligo-utils/simple-utils/location.ml b/vendors/ligo-utils/simple-utils/location.ml index a710e1185..27ecec4f3 100644 --- a/vendors/ligo-utils/simple-utils/location.ml +++ b/vendors/ligo-utils/simple-utils/location.ml @@ -30,6 +30,7 @@ type 'a wrap = { } let wrap ?(loc = generated) wrap_content = { wrap_content ; location = loc } +let get_location x = x.location let unwrap { wrap_content ; _ } = wrap_content let map f x = { x with wrap_content = f x.wrap_content } let pp_wrap f ppf { wrap_content ; _ } = Format.fprintf ppf "%a" f wrap_content From 009b0331e9ac6db732de347d12d485b8f8bb7f0e Mon Sep 17 00:00:00 2001 From: Galfour Date: Wed, 29 May 2019 22:09:40 +0000 Subject: [PATCH 4/8] add cameligo to the cli --- src/bin/cli.ml | 99 ++++++++++++---------------- src/main/contract.ml | 83 +++++++++++++++-------- src/main/main.ml | 32 +-------- src/parser/ligodity.ml | 95 +++++++++++++++++++++++++++ src/parser/ligodity/Parser.mly | 3 +- src/parser/parser.ml | 116 +-------------------------------- src/parser/pascaligo.ml | 114 ++++++++++++++++++++++++++++++++ src/simplify/simplify.ml | 2 +- src/test/bin_tests.ml | 2 +- 9 files changed, 311 insertions(+), 235 deletions(-) create mode 100644 src/parser/ligodity.ml create mode 100644 src/parser/pascaligo.ml diff --git a/src/bin/cli.ml b/src/bin/cli.ml index a37d5ffcd..7e3873d48 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -11,95 +11,76 @@ let main = let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in (term , Term.info "ligo") +let source = + let open Arg in + let info = + let docv = "SOURCE_FILE" in + let doc = "$(docv) is the path to the .ligo file of the contract." in + info ~docv ~doc [] in + required @@ pos 0 (some string) None info + +let entry_point = + let open Arg in + let info = + let docv = "ENTRY_POINT" in + let doc = "$(docv) is entry-point that will be compiled." in + info ~docv ~doc [] in + value @@ pos 1 string "main" info + +let expression = + let open Arg in + let docv = "EXPRESSION" in + let doc = "$(docv) is the expression that will be compiled." in + let info = info ~docv ~doc [] in + required @@ pos 2 (some string) None info + +let syntax = + let open Arg in + let info = + let docv = "SYNTAX" in + let doc = "$(docv) is the syntax that will be used. Currently supported syntaxes are \"pascaligo\" and \"cameligo\". \"pascaligo\" is the default." in + info ~docv ~doc [] in + value @@ opt string "pascaligo" info + let compile_file = - let f source entry_point = + let f source entry_point syntax = toplevel @@ let%bind contract = trace (simple_error "compile michelson") @@ - Ligo.Contract.compile_contract_file source entry_point in + Ligo.Contract.compile_contract_file source entry_point syntax in Format.printf "Contract:\n%s\n" contract ; ok () in let term = - let source = - let open Arg in - let info = - let docv = "SOURCE_FILE" in - let doc = "$(docv) is the path to the .ligo file of the contract." in - info ~docv ~doc [] in - required @@ pos 0 (some string) None info in - let entry_point = - let open Arg in - let info = - let docv = "ENTRY_POINT" in - let doc = "$(docv) is entry-point that will be compiled." in - info ~docv ~doc [] in - value @@ pos 1 string "main" info in - Term.(const f $ source $ entry_point) in + Term.(const f $ source $ entry_point $ syntax) in let docs = "Compile contracts." in (term , Term.info ~docs "compile-contract") let compile_parameter = - let f source entry_point expression = + let f source entry_point expression syntax = toplevel @@ let%bind value = trace (simple_error "compile-input") @@ - Ligo.Contract.compile_contract_parameter source entry_point expression in + Ligo.Contract.compile_contract_parameter source entry_point expression syntax in Format.printf "Input:\n%s\n" value; ok () in let term = - let source = - let open Arg in - let docv = "SOURCE_FILE" in - let doc = "$(docv) is the path to the .ligo file of the contract." in - let info = info ~docv ~doc [] in - required @@ pos 0 (some string) None info in - let entry_point = - let open Arg in - let docv = "ENTRY_POINT" in - let doc = "$(docv) is the entry-point of the contract." in - let info = info ~docv ~doc [] in - required @@ pos 1 (some string) None info in - let expression = - let open Arg in - let docv = "EXPRESSION" in - let doc = "$(docv) is the expression that will be compiled." in - let info = info ~docv ~doc [] in - required @@ pos 2 (some string) None info in - Term.(const f $ source $ entry_point $ expression) in + Term.(const f $ source $ entry_point $ expression $ syntax) in let docs = "Compile contracts parameters." in (term , Term.info ~docs "compile-parameter") let compile_storage = - let f source entry_point expression = + let f source entry_point expression syntax = toplevel @@ let%bind value = trace (simple_error "compile-storage") @@ - Ligo.Contract.compile_contract_storage source entry_point expression in + Ligo.Contract.compile_contract_storage source entry_point expression syntax in Format.printf "Storage:\n%s\n" value; ok () in let term = - let source = - let open Arg in - let docv = "SOURCE_FILE" in - let doc = "$(docv) is the path to the .ligo file of the contract." in - let info = info ~docv ~doc [] in - required @@ pos 0 (some string) None info in - let entry_point = - let open Arg in - let docv = "ENTRY_POINT" in - let doc = "$(docv) is the entry-point of the contract." in - let info = info ~docv ~doc [] in - required @@ pos 1 (some string) None info in - let expression = - let open Arg in - let docv = "EXPRESSION" in - let doc = "$(docv) is the expression that will be compiled." in - let info = info ~docv ~doc [] in - required @@ pos 2 (some string) None info in - Term.(const f $ source $ entry_point $ expression) in + Term.(const f $ source $ entry_point $ expression $ syntax) in let docs = "Compile contracts storage." in (term , Term.info ~docs "compile-storage") diff --git a/src/main/contract.ml b/src/main/contract.ml index 0ad44f983..d49cbd478 100644 --- a/src/main/contract.ml +++ b/src/main/contract.ml @@ -59,13 +59,60 @@ let transpile_value let%bind r = Run_mini_c.run_entry f input in ok r -let compile_contract_file : string -> string -> string result = fun source entry_point -> +let parsify_pascaligo = fun source -> let%bind raw = trace (simple_error "parsing") @@ - Parser.parse_file source in + Parser.Pascaligo.parse_file source in let%bind simplified = trace (simple_error "simplifying") @@ Simplify.Pascaligo.simpl_program raw in + ok simplified + +let parsify_expression_pascaligo = fun source -> + let%bind raw = + trace (simple_error "parsing expression") @@ + Parser.Pascaligo.parse_expression source in + let%bind simplified = + trace (simple_error "simplifying expression") @@ + Simplify.Pascaligo.simpl_expression raw in + ok simplified + +let parsify_ligodity = fun source -> + let%bind raw = + trace (simple_error "parsing") @@ + Parser.Ligodity.parse_file source in + let%bind simplified = + trace (simple_error "simplifying") @@ + Simplify.Ligodity.simpl_program raw in + ok simplified + +let parsify_expression_ligodity = fun source -> + let%bind raw = + trace (simple_error "parsing expression") @@ + Parser.Ligodity.parse_expression source in + let%bind simplified = + trace (simple_error "simplifying expression") @@ + Simplify.Ligodity.simpl_expression raw in + ok simplified + +let parsify = fun syntax source -> + let%bind parsify = match syntax with + | "pascaligo" -> ok parsify_pascaligo + | "cameligo" + | _ -> simple_fail "unrecognized parser" + in + parsify source + +let parsify_expression = fun syntax source -> + let%bind parsify = match syntax with + | "pascaligo" -> ok parsify_expression_pascaligo + | "cameligo" + | _ -> simple_fail "unrecognized parser" + in + parsify source + +let compile_contract_file : string -> string -> string -> string result = fun source entry_point syntax -> + let%bind simplified = parsify syntax source in let%bind () = assert_entry_point_defined simplified entry_point in let%bind typed = @@ -81,14 +128,9 @@ let compile_contract_file : string -> string -> string result = fun source entry Format.asprintf "%a" Michelson.pp_stripped michelson in ok str -let compile_contract_parameter : string -> string -> string -> string result = fun source entry_point expression -> +let compile_contract_parameter : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> let%bind (program , parameter_tv) = - let%bind raw = - trace (simple_error "parsing file") @@ - Parser.parse_file source in - let%bind simplified = - trace (simple_error "simplifying file") @@ - Simplify.Pascaligo.simpl_program raw in + let%bind simplified = parsify syntax source in let%bind () = assert_entry_point_defined simplified entry_point in let%bind typed = @@ -99,13 +141,8 @@ let compile_contract_parameter : string -> string -> string -> string result = f ok (typed , param_ty) in let%bind expr = - let%bind raw = - trace (simple_error "parsing expression") @@ - Parser.parse_expression expression in - let%bind simplified = - trace (simple_error "simplifying expression") @@ - Simplify.Pascaligo.simpl_expression raw in let%bind typed = + let%bind simplified = parsify_expression syntax expression in let env = let last_declaration = Location.unwrap List.(hd @@ rev program) in match last_declaration with @@ -129,14 +166,9 @@ let compile_contract_parameter : string -> string -> string -> string result = f ok expr -let compile_contract_storage : string -> string -> string -> string result = fun source entry_point expression -> +let compile_contract_storage : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> let%bind (program , storage_tv) = - let%bind raw = - trace (simple_error "parsing file") @@ - Parser.parse_file source in - let%bind simplified = - trace (simple_error "simplifying file") @@ - Simplify.Pascaligo.simpl_program raw in + let%bind simplified = parsify syntax source in let%bind () = assert_entry_point_defined simplified entry_point in let%bind typed = @@ -147,12 +179,7 @@ let compile_contract_storage : string -> string -> string -> string result = fun ok (typed , storage_ty) in let%bind expr = - let%bind raw = - trace (simple_error "parsing expression") @@ - Parser.parse_expression expression in - let%bind simplified = - trace (simple_error "simplifying expression") @@ - Simplify.Pascaligo.simpl_expression raw in + let%bind simplified = parsify_expression syntax expression in let%bind typed = let env = let last_declaration = Location.unwrap List.(hd @@ rev program) in diff --git a/src/main/main.ml b/src/main/main.ml index a27134270..15f2dde7d 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -46,7 +46,7 @@ let compile : Mini_c.program -> string -> Compiler.Program.compiled_program resu let type_file ?(debug_simplify = false) ?(debug_typed = false) (path:string) : AST_Typed.program result = - let%bind raw = Parser.parse_file path in + let%bind raw = Parser.Pascaligo.parse_file path in let%bind simpl = trace (simple_error "simplifying") @@ simplify raw in @@ -162,35 +162,5 @@ let easy_run_typed_simplified let%bind annotated_result = untype_expression typed_result in ok annotated_result -let easy_run_main_typed - ?(debug_mini_c = false) - (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = - easy_run_typed ~debug_mini_c "main" program input - -let easy_run_main (path:string) (input:string) : AST_Typed.annotated_expression result = - let%bind typed = type_file path in - - let%bind raw_expr = Parser.parse_expression input in - let%bind simpl_expr = simplify_expr raw_expr in - let%bind typed_expr = type_expression simpl_expr in - easy_run_main_typed typed typed_expr - -let compile_file (source: string) (entry_point:string) : Michelson.t result = - let%bind raw = - trace (simple_error "parsing") @@ - Parser.parse_file source in - let%bind simplified = - trace (simple_error "simplifying") @@ - simplify raw in - let%bind typed = - trace (simple_error "typing") @@ - type_ simplified in - let%bind mini_c = - trace (simple_error "transpiling") @@ - transpile typed in - let%bind {body = michelson} = - trace (simple_error "compiling") @@ - compile mini_c entry_point in - ok michelson module Contract = Contract diff --git a/src/parser/ligodity.ml b/src/parser/ligodity.ml new file mode 100644 index 000000000..9d49908b6 --- /dev/null +++ b/src/parser/ligodity.ml @@ -0,0 +1,95 @@ +open Trace +open Parser_ligodity +module Parser = Parser_ligodity.Parser +module AST = Parser_ligodity.AST + +let parse_file (source: string) : AST.t result = + let pp_input = + let prefix = Filename.(source |> basename |> remove_extension) + and suffix = ".pp.ligo" + in prefix ^ suffix in + + let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" + source pp_input in + let%bind () = sys_command cpp_cmd in + + let%bind channel = + generic_try (simple_error "error opening file") @@ + (fun () -> open_in pp_input) in + let lexbuf = Lexing.from_channel channel in + let read = Lexer.get_token in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str + ) + | exn -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Printexc.to_string exn) + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str + ) @@ (fun () -> Parser.program read lexbuf) >>? fun raw -> + ok raw + +let parse_string (s:string) : AST.t result = + + let lexbuf = Lexing.from_string s in + let read = Lexer.get_token in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> Parser.program read lexbuf) >>? fun raw -> + ok raw + +let parse_expression (s:string) : AST.expr result = + let lexbuf = Lexing.from_string s in + let read = Lexer.get_token in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | exn -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n" + (Printexc.to_string exn) + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname s + in + simple_error str + ) @@ (fun () -> Parser.expr read lexbuf) >>? fun raw -> + ok raw diff --git a/src/parser/ligodity/Parser.mly b/src/parser/ligodity/Parser.mly index 3c7f57a7e..88f191f51 100644 --- a/src/parser/ligodity/Parser.mly +++ b/src/parser/ligodity/Parser.mly @@ -184,8 +184,9 @@ let norm_fun_expr patterns expr = (* Entry points *) -%start program +%start program expr %type program +%type expr %% diff --git a/src/parser/parser.ml b/src/parser/parser.ml index fd2316936..e53e2913d 100644 --- a/src/parser/parser.ml +++ b/src/parser/parser.ml @@ -1,117 +1,5 @@ -open Trace - -module Pascaligo = Parser_pascaligo +module Pascaligo = Pascaligo module Camligo = Parser_camligo -module Ligodity = Parser_ligodity - -open Parser_pascaligo -module AST_Raw = Parser_pascaligo.AST +module Ligodity = Ligodity -let parse_file (source: string) : AST_Raw.t result = - let pp_input = - let prefix = Filename.(source |> basename |> remove_extension) - and suffix = ".pp.ligo" - in prefix ^ suffix in - - let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" - source pp_input in - let%bind () = sys_command cpp_cmd in - - let%bind channel = - generic_try (simple_error "error opening file") @@ - (fun () -> open_in pp_input) in - let lexbuf = Lexing.from_channel channel in - let module Lexer = Lexer.Make(LexToken) in - let Lexer.{read ; close ; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) - | exn -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Printexc.to_string exn) - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw - -let parse_string (s:string) : AST_Raw.t result = - let lexbuf = Lexing.from_string s in - let module Lexer = Lexer.Make(LexToken) in - let Lexer.{read ; close ; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw - -let parse_expression (s:string) : AST_Raw.expr result = - let lexbuf = Lexing.from_string s in - let module Lexer = Lexer.Make(LexToken) in - let Lexer.{read ; close; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | exn -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n" - (Printexc.to_string exn) - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname s - in - simple_error str - ) @@ (fun () -> - let raw = Parser.interactive_expr read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw diff --git a/src/parser/pascaligo.ml b/src/parser/pascaligo.ml new file mode 100644 index 000000000..1f95166e2 --- /dev/null +++ b/src/parser/pascaligo.ml @@ -0,0 +1,114 @@ +open Trace +open Parser_pascaligo +module Parser = Parser_pascaligo.Parser +module AST = Parser_pascaligo.AST +module ParserLog = Parser_pascaligo.ParserLog + +let parse_file (source: string) : AST.t result = + let pp_input = + let prefix = Filename.(source |> basename |> remove_extension) + and suffix = ".pp.ligo" + in prefix ^ suffix in + + let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" + source pp_input in + let%bind () = sys_command cpp_cmd in + + let%bind channel = + generic_try (simple_error "error opening file") @@ + (fun () -> open_in pp_input) in + let lexbuf = Lexing.from_channel channel in + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close ; _} = + Lexer.open_token_stream None in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str + ) + | exn -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Printexc.to_string exn) + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str + ) @@ (fun () -> + let raw = Parser.contract read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw + +let parse_string (s:string) : AST.t result = + + let lexbuf = Lexing.from_string s in + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close ; _} = + Lexer.open_token_stream None in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> + let raw = Parser.contract read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw + +let parse_expression (s:string) : AST.expr result = + let lexbuf = Lexing.from_string s in + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close; _} = + Lexer.open_token_stream None in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | exn -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n" + (Printexc.to_string exn) + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname s + in + simple_error str + ) @@ (fun () -> + let raw = Parser.interactive_expr read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw diff --git a/src/simplify/simplify.ml b/src/simplify/simplify.ml index f0b71b684..d798d0ed1 100644 --- a/src/simplify/simplify.ml +++ b/src/simplify/simplify.ml @@ -1,3 +1,3 @@ module Pascaligo = Pascaligo module Camligo = Camligo -(*module Ligodity = Ligodity*) +module Ligodity = Ligodity diff --git a/src/test/bin_tests.ml b/src/test/bin_tests.ml index bb97f75cc..f159e6287 100644 --- a/src/test/bin_tests.ml +++ b/src/test/bin_tests.ml @@ -4,7 +4,7 @@ open Test_helpers let compile_contract_basic () : unit result = let%bind _ = - Contract.compile_contract_file "./contracts/dispatch-counter.ligo" "main" + Contract.compile_contract_file "./contracts/dispatch-counter.ligo" "main" "pascaligo" in ok () From 320d0c1a720017c44f682a4ec718ee34281a1e89 Mon Sep 17 00:00:00 2001 From: Galfour Date: Fri, 31 May 2019 19:56:51 +0000 Subject: [PATCH 5/8] various refactorings to prepare tests; tests for ligodity don't pass --- src/main/contract.ml | 4 +- src/main/main.ml | 271 +++++++++----------- src/main/run_mini_c.ml | 22 -- src/main/run_simplified.ml | 24 ++ src/main/run_source.ml | 218 ++++++++++++++++ src/main/run_typed.ml | 64 +++++ src/simplify/pascaligo.ml | 1 + src/test/bin_tests.ml | 4 +- src/test/coase_tests.ml | 4 +- src/test/heap_tests.ml | 30 ++- src/test/integration_tests.ml | 20 +- src/test/test_helpers.ml | 6 +- src/transpiler/transpiler.ml | 12 +- vendors/ligo-utils/simple-utils/trace.ml | 24 +- vendors/ligo-utils/simple-utils/x_option.ml | 3 +- 15 files changed, 484 insertions(+), 223 deletions(-) create mode 100644 src/main/run_simplified.ml create mode 100644 src/main/run_source.ml create mode 100644 src/main/run_typed.ml diff --git a/src/main/contract.ml b/src/main/contract.ml index d49cbd478..84f856c7c 100644 --- a/src/main/contract.ml +++ b/src/main/contract.ml @@ -98,7 +98,7 @@ let parsify_expression_ligodity = fun source -> let parsify = fun syntax source -> let%bind parsify = match syntax with | "pascaligo" -> ok parsify_pascaligo - | "cameligo" + | "cameligo" -> ok parsify_ligodity | _ -> simple_fail "unrecognized parser" in parsify source @@ -106,7 +106,7 @@ let parsify = fun syntax source -> let parsify_expression = fun syntax source -> let%bind parsify = match syntax with | "pascaligo" -> ok parsify_expression_pascaligo - | "cameligo" + | "cameligo" -> ok parsify_expression_ligodity | _ -> simple_fail "unrecognized parser" in parsify source diff --git a/src/main/main.ml b/src/main/main.ml index 15f2dde7d..b24f522d4 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -1,6 +1,6 @@ module Run_mini_c = Run_mini_c -open Trace +(* open Trace *) module Parser = Parser module AST_Raw = Parser.Pascaligo.AST module AST_Simplified = Ast_simplified @@ -8,159 +8,128 @@ module AST_Typed = Ast_typed module Mini_c = Mini_c module Typer = Typer module Transpiler = Transpiler + +module Run = struct + include Run_source + include Run_simplified + include Run_typed + include Run_mini_c +end + (* module Parser_multifix = Multifix * module Simplify_multifix = Simplify_multifix *) -let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p -let simplify_expr (e:AST_Raw.expr) : Ast_simplified.expression result = Simplify.Pascaligo.simpl_expression e -let unparse_simplified_expr (e:AST_Simplified.expression) : string result = - ok @@ Format.asprintf "%a" AST_Simplified.PP.expression e - -let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p -let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty) - (e:AST_Simplified.expression) : AST_Typed.annotated_expression result = - Typer.type_expression env e -let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.expression result = Typer.untype_expression e - -let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p -let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name -let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e -let transpile_value - (e:AST_Typed.annotated_expression) : Mini_c.value result = - let%bind f = - let open Transpiler in - let (f , _) = functionalize e in - let%bind main = translate_main f in - ok main - in - - let input = Mini_c.Combinators.d_unit in - let%bind r = Run_mini_c.run_entry f input in - ok r - -let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result = - Transpiler.untranspile v e - -let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program - -let type_file ?(debug_simplify = false) ?(debug_typed = false) - (path:string) : AST_Typed.program result = - let%bind raw = Parser.Pascaligo.parse_file path in - let%bind simpl = - trace (simple_error "simplifying") @@ - simplify raw in - (if debug_simplify then - Format.(printf "Simplified : %a\n%!" AST_Simplified.PP.program simpl) - ) ; - let%bind typed = - trace (simple_error "typing") @@ - type_ simpl in - (if debug_typed then ( - Format.(printf "Typed : %a\n%!" AST_Typed.PP.program typed) - )) ; - ok typed +(* let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p + * let simplify_expr (e:AST_Raw.expr) : Ast_simplified.expression result = Simplify.Pascaligo.simpl_expression e + * let unparse_simplified_expr (e:AST_Simplified.expression) : string result = + * ok @@ Format.asprintf "%a" AST_Simplified.PP.expression e + * + * let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p + * let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty) + * (e:AST_Simplified.expression) : AST_Typed.annotated_expression result = + * Typer.type_expression env e + * let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.expression result = Typer.untype_expression e + * + * let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p + * let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name + * let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e + * + * let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result = + * Transpiler.untranspile v e + * + * let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program + * + * let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result = + * let%bind result = + * let%bind mini_c_main = + * transpile_entry program entry in + * Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in + * let%bind typed_result = + * let%bind typed_main = Ast_typed.get_entry program entry in + * untranspile_value result typed_main.type_annotation in + * ok typed_result + * + * + * let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed") + * + * + * let easy_run_typed + * ?(debug_mini_c = false) ?options (entry:string) + * (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = + * let%bind () = + * let open Ast_typed in + * let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in + * let%bind (arg_ty , _) = + * trace_strong (simple_error "entry-point doesn't have a function type") @@ + * get_t_function @@ get_type_annotation d.annotated_expression in + * Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) + * in + * + * let%bind mini_c_main = + * trace (simple_error "transpile mini_c entry") @@ + * transpile_entry program entry in + * (if debug_mini_c then + * Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) + * ) ; + * + * let%bind mini_c_value = transpile_value input in + * + * let%bind mini_c_result = + * let error = + * let title () = "run Mini_c" in + * let content () = + * Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main + * in + * error title content in + * trace error @@ + * Run_mini_c.run_entry ?options mini_c_main mini_c_value in + * let%bind typed_result = + * let%bind main_result_type = + * let%bind typed_main = Ast_typed.get_functional_entry program entry in + * match (snd typed_main).type_value' with + * | T_function (_, result) -> ok result + * | _ -> simple_fail "main doesn't have fun type" in + * untranspile_value mini_c_result main_result_type in + * ok typed_result + * + * let easy_run_typed_simplified + * ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) + * (program:AST_Typed.program) (input:Ast_simplified.expression) : Ast_simplified.expression result = + * let%bind mini_c_main = + * trace (simple_error "transpile mini_c entry") @@ + * transpile_entry program entry in + * (if debug_mini_c then + * Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) + * ) ; + * + * let%bind typed_value = + * let env = + * let last_declaration = Location.unwrap List.(hd @@ rev program) in + * match last_declaration with + * | Declaration_constant (_ , (_ , post_env)) -> post_env + * in + * type_expression ~env input in + * let%bind mini_c_value = transpile_value typed_value in + * + * let%bind mini_c_result = + * let error = + * let title () = "run Mini_c" in + * let content () = + * Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main + * in + * error title content in + * trace error @@ + * Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in + * let%bind typed_result = + * let%bind main_result_type = + * let%bind typed_main = Ast_typed.get_functional_entry program entry in + * match (snd typed_main).type_value' with + * | T_function (_, result) -> ok result + * | _ -> simple_fail "main doesn't have fun type" in + * untranspile_value mini_c_result main_result_type in + * let%bind annotated_result = untype_expression typed_result in + * ok annotated_result *) -let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result = - let%bind result = - let%bind mini_c_main = - transpile_entry program entry in - Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in - let%bind typed_result = - let%bind typed_main = Ast_typed.get_entry program entry in - untranspile_value result typed_main.type_annotation in - ok typed_result - -let easy_evaluate_typed_simplified (entry:string) (program:AST_Typed.program) : Ast_simplified.expression result = - let%bind result = - let%bind mini_c_main = - transpile_entry program entry in - Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in - let%bind typed_result = - let%bind typed_main = Ast_typed.get_entry program entry in - untranspile_value result typed_main.type_annotation in - let%bind annotated_result = untype_expression typed_result in - ok annotated_result - -let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed") - -let easy_run_typed - ?(debug_mini_c = false) ?options (entry:string) - (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = - let%bind () = - let open Ast_typed in - let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in - let%bind (arg_ty , _) = - trace_strong (simple_error "entry-point doesn't have a function type") @@ - get_t_function @@ get_type_annotation d.annotated_expression in - Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) - in - - let%bind mini_c_main = - trace (simple_error "transpile mini_c entry") @@ - transpile_entry program entry in - (if debug_mini_c then - Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) - ) ; - - let%bind mini_c_value = transpile_value input in - - let%bind mini_c_result = - let error = - let title () = "run Mini_c" in - let content () = - Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main - in - error title content in - trace error @@ - Run_mini_c.run_entry ?options mini_c_main mini_c_value in - let%bind typed_result = - let%bind main_result_type = - let%bind typed_main = Ast_typed.get_functional_entry program entry in - match (snd typed_main).type_value' with - | T_function (_, result) -> ok result - | _ -> simple_fail "main doesn't have fun type" in - untranspile_value mini_c_result main_result_type in - ok typed_result - -let easy_run_typed_simplified - ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) - (program:AST_Typed.program) (input:Ast_simplified.expression) : Ast_simplified.expression result = - let%bind mini_c_main = - trace (simple_error "transpile mini_c entry") @@ - transpile_entry program entry in - (if debug_mini_c then - Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) - ) ; - - let%bind typed_value = - let env = - let last_declaration = Location.unwrap List.(hd @@ rev program) in - match last_declaration with - | Declaration_constant (_ , (_ , post_env)) -> post_env - in - type_expression ~env input in - let%bind mini_c_value = transpile_value typed_value in - - let%bind mini_c_result = - let error = - let title () = "run Mini_c" in - let content () = - Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main - in - error title content in - trace error @@ - Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in - let%bind typed_result = - let%bind main_result_type = - let%bind typed_main = Ast_typed.get_functional_entry program entry in - match (snd typed_main).type_value' with - | T_function (_, result) -> ok result - | _ -> simple_fail "main doesn't have fun type" in - untranspile_value mini_c_result main_result_type in - let%bind annotated_result = untype_expression typed_result in - ok annotated_result - - -module Contract = Contract +(* module Contract = Contract *) diff --git a/src/main/run_mini_c.ml b/src/main/run_mini_c.ml index adad4c05c..17fc40ba2 100644 --- a/src/main/run_mini_c.ml +++ b/src/main/run_mini_c.ml @@ -22,14 +22,6 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in ok (Ex_typed_value (output_ty, output)) -let run_node (program:program) (input:Michelson.t) : Michelson.t result = - let%bind compiled = translate_program program "main" in - let%bind (Ex_typed_value (output_ty, output)) = run_aux compiled input in - let%bind output = - Trace.trace_tzresult_lwt (simple_error "error unparsing output") @@ - Memory_proto_alpha.unparse_michelson_data output_ty output in - ok output - let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:value) : value result = let%bind compiled = let error = @@ -45,17 +37,3 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:v let%bind ex_ty_value = run_aux ?options compiled input_michelson in let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in ok result - -let run (program:program) (input:value) : value result = - let%bind input_michelson = translate_value input in - let%bind compiled = translate_program program "main" in - let%bind ex_ty_value = run_aux compiled input_michelson in - let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in - ok result - -let expression_to_value (e:expression) : value result = - match (Combinators.Expression.get_content e) with - | E_literal v -> ok v - | _ -> fail - @@ error (thunk "not a value") - @@ (fun () -> Format.asprintf "%a" PP.expression e) diff --git a/src/main/run_simplified.ml b/src/main/run_simplified.ml new file mode 100644 index 000000000..898ba6954 --- /dev/null +++ b/src/main/run_simplified.ml @@ -0,0 +1,24 @@ +open Trace + +let run_simplityped + ?options + ?(debug_mini_c = false) ?(debug_michelson = false) + (program : Ast_typed.program) (entry : string) + (input : Ast_simplified.expression) : Ast_simplified.expression result = + let%bind typed_input = + let env = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , (_ , post_env)) -> post_env + in + Typer.type_expression env input in + let%bind typed_result = + Run_typed.run_typed ?options ~debug_mini_c ~debug_michelson entry program typed_input in + let%bind annotated_result = Typer.untype_expression typed_result in + ok annotated_result + +let evaluate_simplityped (program : Ast_typed.program) (entry : string) + : Ast_simplified.expression result = + let%bind typed_result = Run_typed.evaluate_typed entry program in + let%bind annotated_result = Typer.untype_expression typed_result in + ok annotated_result diff --git a/src/main/run_source.ml b/src/main/run_source.ml new file mode 100644 index 000000000..1c452c91d --- /dev/null +++ b/src/main/run_source.ml @@ -0,0 +1,218 @@ +open Trace + +include struct + open Ast_simplified + + let assert_entry_point_defined : program -> string -> unit result = + fun program entry_point -> + let aux : declaration -> bool = fun declaration -> + match declaration with + | Declaration_type _ -> false + | Declaration_constant (name , _ , _) -> name = entry_point + in + trace_strong (simple_error "no entry-point with given name") @@ + Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program +end + +include struct + open Ast_typed + open Combinators + + let get_entry_point_type : type_value -> (type_value * type_value) result = fun t -> + let%bind (arg , result) = + trace_strong (simple_error "entry-point doesn't have a function type") @@ + get_t_function t in + let%bind (arg' , storage_param) = + trace_strong (simple_error "entry-point doesn't have 2 parameters") @@ + get_t_pair arg in + let%bind (ops , storage_result) = + trace_strong (simple_error "entry-point doesn't have 2 results") @@ + get_t_pair result in + let%bind () = + trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@ + assert_t_list_operation ops in + let%bind () = + trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@ + assert_type_value_eq (storage_param , storage_result) in + ok (arg' , storage_param) + + let get_entry_point : program -> string -> (type_value * type_value) result = fun p e -> + let%bind declaration = get_declaration_by_name p e in + match declaration with + | Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation + + let assert_valid_entry_point = fun p e -> + let%bind _ = get_entry_point p e in + ok () +end + +let transpile_value + (e:Ast_typed.annotated_expression) : Mini_c.value result = + let%bind f = + let open Transpiler in + let (f , _) = functionalize e in + let%bind main = translate_main f in + ok main + in + + let input = Mini_c.Combinators.d_unit in + let%bind r = Run_mini_c.run_entry f input in + ok r + +let parsify_pascaligo = fun source -> + let%bind raw = + trace (simple_error "parsing") @@ + Parser.Pascaligo.parse_file source in + let%bind simplified = + trace (simple_error "simplifying") @@ + Simplify.Pascaligo.simpl_program raw in + ok simplified + +let parsify_expression_pascaligo = fun source -> + let%bind raw = + trace (simple_error "parsing expression") @@ + Parser.Pascaligo.parse_expression source in + let%bind simplified = + trace (simple_error "simplifying expression") @@ + Simplify.Pascaligo.simpl_expression raw in + ok simplified + +let parsify_ligodity = fun source -> + let%bind raw = + trace (simple_error "parsing") @@ + Parser.Ligodity.parse_file source in + let%bind simplified = + trace (simple_error "simplifying") @@ + Simplify.Ligodity.simpl_program raw in + ok simplified + +let parsify_expression_ligodity = fun source -> + let%bind raw = + trace (simple_error "parsing expression") @@ + Parser.Ligodity.parse_expression source in + let%bind simplified = + trace (simple_error "simplifying expression") @@ + Simplify.Ligodity.simpl_expression raw in + ok simplified + +let parsify = fun syntax source -> + let%bind parsify = match syntax with + | "pascaligo" -> ok parsify_pascaligo + | "cameligo" -> ok parsify_ligodity + | _ -> simple_fail "unrecognized parser" + in + parsify source + +let parsify_expression = fun syntax source -> + let%bind parsify = match syntax with + | "pascaligo" -> ok parsify_expression_pascaligo + | "cameligo" -> ok parsify_expression_ligodity + | _ -> simple_fail "unrecognized parser" + in + parsify source + +let compile_contract_file : string -> string -> string -> string result = fun source entry_point syntax -> + let%bind simplified = parsify syntax source in + let%bind () = + assert_entry_point_defined simplified entry_point in + let%bind typed = + trace (simple_error "typing") @@ + Typer.type_program simplified in + let%bind mini_c = + trace (simple_error "transpiling") @@ + Transpiler.translate_entry typed entry_point in + let%bind michelson = + trace (simple_error "compiling") @@ + Compiler.translate_contract mini_c in + let str = + Format.asprintf "%a" Michelson.pp_stripped michelson in + ok str + +let compile_contract_parameter : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> + let%bind (program , parameter_tv) = + let%bind simplified = parsify syntax source in + let%bind () = + assert_entry_point_defined simplified entry_point in + let%bind typed = + trace (simple_error "typing file") @@ + Typer.type_program simplified in + let%bind (param_ty , _) = + get_entry_point typed entry_point in + ok (typed , param_ty) + in + let%bind expr = + let%bind typed = + let%bind simplified = parsify_expression syntax expression in + let env = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , (_ , post_env)) -> post_env + in + trace (simple_error "typing expression") @@ + Typer.type_expression env simplified in + let%bind () = + trace (simple_error "expression type doesn't match type parameter") @@ + Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in + let%bind mini_c = + trace (simple_error "transpiling expression") @@ + transpile_value typed in + let%bind michelson = + trace (simple_error "compiling expression") @@ + Compiler.translate_value mini_c in + let str = + Format.asprintf "%a" Michelson.pp_stripped michelson in + ok str + in + ok expr + + +let compile_contract_storage : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> + let%bind (program , storage_tv) = + let%bind simplified = parsify syntax source in + let%bind () = + assert_entry_point_defined simplified entry_point in + let%bind typed = + trace (simple_error "typing file") @@ + Typer.type_program simplified in + let%bind (_ , storage_ty) = + get_entry_point typed entry_point in + ok (typed , storage_ty) + in + let%bind expr = + let%bind simplified = parsify_expression syntax expression in + let%bind typed = + let env = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , (_ , post_env)) -> post_env + in + trace (simple_error "typing expression") @@ + Typer.type_expression env simplified in + let%bind () = + trace (simple_error "expression type doesn't match type storage") @@ + Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in + let%bind mini_c = + trace (simple_error "transpiling expression") @@ + transpile_value typed in + let%bind michelson = + trace (simple_error "compiling expression") @@ + Compiler.translate_value mini_c in + let str = + Format.asprintf "%a" Michelson.pp_stripped michelson in + ok str + in + ok expr + +let type_file ?(debug_simplify = false) ?(debug_typed = false) + syntax (path:string) : Ast_typed.program result = + let%bind simpl = parsify syntax path in + (if debug_simplify then + Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) + ) ; + let%bind typed = + trace (simple_error "typing") @@ + Typer.type_program simpl in + (if debug_typed then ( + Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed) + )) ; + ok typed diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml new file mode 100644 index 000000000..a7f9fdc58 --- /dev/null +++ b/src/main/run_typed.ml @@ -0,0 +1,64 @@ +open Trace + +let transpile_value + (e:Ast_typed.annotated_expression) : Mini_c.value result = + let%bind f = + let open Transpiler in + let (f , _) = functionalize e in + let%bind main = translate_main f in + ok main + in + + let input = Mini_c.Combinators.d_unit in + let%bind r = Run_mini_c.run_entry f input in + ok r + +let evaluate_typed (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result = + trace (simple_error "easy evaluate typed") @@ + let%bind result = + let%bind mini_c_main = + Transpiler.translate_entry program entry in + Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in + let%bind typed_result = + let%bind typed_main = Ast_typed.get_entry program entry in + Transpiler.untranspile result typed_main.type_annotation in + ok typed_result + +let run_typed + ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) + (program:Ast_typed.program) (input:Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = + let%bind () = + let open Ast_typed in + let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in + let%bind (arg_ty , _) = + trace_strong (simple_error "entry-point doesn't have a function type") @@ + get_t_function @@ get_type_annotation d.annotated_expression in + Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) + in + + let%bind mini_c_main = + trace (simple_error "transpile mini_c entry") @@ + Transpiler.translate_entry program entry in + (if debug_mini_c then + Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) + ) ; + + let%bind mini_c_value = transpile_value input in + + let%bind mini_c_result = + let error = + let title () = "run Mini_c" in + let content () = + Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main + in + error title content in + trace error @@ + Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in + let%bind typed_result = + let%bind main_result_type = + let%bind typed_main = Ast_typed.get_functional_entry program entry in + match (snd typed_main).type_value' with + | T_function (_, result) -> ok result + | _ -> simple_fail "main doesn't have fun type" in + Transpiler.untranspile mini_c_result main_result_type in + ok typed_result diff --git a/src/simplify/pascaligo.ml b/src/simplify/pascaligo.ml index 038fd4484..bf907b1fb 100644 --- a/src/simplify/pascaligo.ml +++ b/src/simplify/pascaligo.ml @@ -351,6 +351,7 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e let arguments_name = "arguments" in let%bind params = bind_map_list simpl_param lst in let (binder , input_type) = + (* let type_expression = T_record (SMap.of_list params) in *) let type_expression = T_tuple (List.map snd params) in (arguments_name , type_expression) in let%bind tpl_declarations = diff --git a/src/test/bin_tests.ml b/src/test/bin_tests.ml index f159e6287..cef36ab94 100644 --- a/src/test/bin_tests.ml +++ b/src/test/bin_tests.ml @@ -1,10 +1,10 @@ open Trace -open Ligo +open Ligo.Run open Test_helpers let compile_contract_basic () : unit result = let%bind _ = - Contract.compile_contract_file "./contracts/dispatch-counter.ligo" "main" "pascaligo" + compile_contract_file "./contracts/dispatch-counter.ligo" "main" "pascaligo" in ok () diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index 4d15754db..e6e086c6c 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -1,9 +1,11 @@ (* Copyright Coase, Inc 2019 *) open Trace -open Ligo +open Ligo.Run open Test_helpers +let type_file = type_file "pascaligo" + let get_program = let s = ref None in fun () -> match !s with diff --git a/src/test/heap_tests.ml b/src/test/heap_tests.ml index 002ae9dbf..c52205720 100644 --- a/src/test/heap_tests.ml +++ b/src/test/heap_tests.ml @@ -1,7 +1,9 @@ open Trace -open Ligo +open Ligo.Run open Test_helpers +let type_file = type_file "pascaligo" + let get_program = let s = ref None in fun () -> match !s with @@ -12,8 +14,8 @@ let get_program = ok program ) -let a_heap_ez ?value_type (content:(int * AST_Typed.ae) list) = - let open AST_Typed.Combinators in +let a_heap_ez ?value_type (content:(int * Ast_typed.ae) list) = + let open Ast_typed.Combinators in let content = let aux = fun (x, y) -> e_a_empty_nat x, y in List.map aux content in @@ -24,7 +26,7 @@ let a_heap_ez ?value_type (content:(int * AST_Typed.ae) list) = e_a_empty_map content (t_nat ()) value_type let ez lst = - let open AST_Typed.Combinators in + let open Ast_typed.Combinators in let value_type = t_pair (t_int ()) (t_string ()) @@ -46,11 +48,11 @@ let dummy n = let is_empty () : unit result = let%bind program = get_program () in let aux n = - let open AST_Typed.Combinators in + let open Ast_typed.Combinators in let input = dummy n in - let%bind result = easy_run_typed "is_empty" program input in + let%bind result = run_typed "is_empty" program input in let expected = e_a_empty_bool (n = 0) in - AST_Typed.assert_value_eq (expected, result) + Ast_typed.assert_value_eq (expected, result) in let%bind _ = bind_list @@ List.map aux @@ -60,15 +62,15 @@ let is_empty () : unit result = let get_top () : unit result = let%bind program = get_program () in let aux n = - let open AST_Typed.Combinators in + let open Ast_typed.Combinators in let input = dummy n in - match n, easy_run_typed "get_top" program input with + match n, run_typed "get_top" program input with | 0, Trace.Ok _ -> simple_fail "unexpected success" | 0, _ -> ok () | _, result -> let%bind result' = result in let expected = e_a_empty_pair (e_a_empty_int 1) (e_a_empty_string "1") in - AST_Typed.assert_value_eq (expected, result') + Ast_typed.assert_value_eq (expected, result') in let%bind _ = bind_list @@ List.map aux @@ -79,7 +81,7 @@ let pop_switch () : unit result = let%bind program = get_program () in let aux n = let input = dummy n in - match n, easy_run_typed "pop_switch" program input with + match n, run_typed "pop_switch" program input with | 0, Trace.Ok _ -> simple_fail "unexpected success" | 0, _ -> ok () | _, result -> @@ -89,7 +91,7 @@ let pop_switch () : unit result = @@ tl @@ range (n + 1) ) in - AST_Typed.assert_value_eq (expected, result') + Ast_typed.assert_value_eq (expected, result') in let%bind _ = bind_list @@ List.map aux @@ -100,9 +102,9 @@ let pop () : unit result = let%bind program = get_program () in let aux n = let input = dummy n in - (match easy_run_typed "pop" program input with + (match run_typed "pop" program input with | Trace.Ok (output , _) -> ( - Format.printf "\nPop output on %d : %a\n" n AST_Typed.PP.annotated_expression output ; + Format.printf "\nPop output on %d : %a\n" n Ast_typed.PP.annotated_expression output ; ) | Errors errs -> ( Format.printf "\nPop output on %d : error\n" n) ; diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index ccbf6e893..ccf47465b 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1,14 +1,11 @@ open Trace -open Ligo +open Ligo.Run open Test_helpers open Ast_simplified.Combinators -let mtype_file path : Ast_typed.program result = - let%bind raw = Parser.Camligo.User.parse_file path in - let%bind simpl = Simplify.Camligo.main raw in - let%bind typed = Ligo.Typer.type_program (Location.unwrap simpl) in - ok typed +let mtype_file = type_file "cameligo" +let type_file = type_file "pascaligo" let function_ () : unit result = let%bind program = type_file "./contracts/function.ligo" in @@ -148,6 +145,9 @@ let include_ () : unit result = let record_ez_int names n = ez_e_record @@ List.map (fun x -> x, e_int n) names +let tuple_ez_int names n = + e_tuple @@ List.map (fun _ -> e_int n) names + let multiple_parameters () : unit result = let%bind program = type_file "./contracts/multiple-parameters.ligo" in let aux ((name : string) , make_input , make_output) = @@ -155,9 +155,9 @@ let multiple_parameters () : unit result = expect_eq_n program name make_input make_output' in let%bind _ = bind_list @@ List.map aux [ - ("ab", record_ez_int ["a";"b"], fun n -> 2 * n) ; - ("abcd", record_ez_int ["a";"b";"c";"d"], fun n -> 4 * n + 2) ; - ("abcde", record_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ; + ("ab", tuple_ez_int ["a";"b"], fun n -> 2 * n) ; + ("abcd", tuple_ez_int ["a";"b";"c";"d"], fun n -> 4 * n + 2) ; + ("abcde", tuple_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ; ] in ok () @@ -437,7 +437,7 @@ let dispatch_counter_contract () : unit result = let basic_mligo () : unit result = let%bind typed = mtype_file "./contracts/basic.mligo" in - let%bind result = Ligo.easy_evaluate_typed "foo" typed in + let%bind result = evaluate_typed "foo" typed in Ligo.AST_Typed.assert_value_eq (Ligo.AST_Typed.Combinators.e_a_empty_int (42 + 127), result) let counter_mligo () : unit result = diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 2b9ff0f44..e1a026af3 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -3,7 +3,7 @@ open! Trace let test name f = Alcotest.test_case name `Quick @@ fun () -> let result = - trace (fun () -> error (thunk "running test") (fun () -> name) ()) @@ + trace (fun () -> error (thunk "running test") (thunk name) ()) @@ f () in match result with | Ok ((), annotations) -> ignore annotations; () @@ -20,7 +20,7 @@ let expect ?options program entry_point input expecter = let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace run_error @@ - Ligo.easy_run_typed_simplified ~debug_michelson:true ?options entry_point program input in + Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input in expecter result let expect_eq ?options program entry_point input expected = @@ -41,7 +41,7 @@ let expect_evaluate program entry_point expecter = let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace error @@ - let%bind result = Ligo.easy_evaluate_typed_simplified entry_point program in + let%bind result = Ligo.Run.evaluate_simplityped program entry_point in expecter result let expect_eq_evaluate program entry_point expected = diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 98792fe6b..a146358fa 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -469,7 +469,7 @@ let translate_main (l:AST.lambda) : anon_function result = | E_literal (D_function f) -> ok f | _ -> simple_fail "main is not a function" -(* From a non-functional expression [expr], build the functional expression [fun () -> expr] *) +(* From an expression [expr], build the expression [fun () -> expr] *) let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value = let t = e.type_annotation in let open! AST in @@ -511,16 +511,6 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result = open Combinators -let rec exp x n = - if n = 0 - then 1 - else - let exp' = exp (x * x) (n / 2) in - let m = if n mod 2 = 0 then 1 else x in - m * exp' - -let exp2 = exp 2 - let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result = let open Append_tree in let rec aux tv : (string * value * AST.type_value) result= diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index c13f852b6..506ad253b 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -131,7 +131,7 @@ let mk_error let data' = let aux (key , value) = (key , `String (value ())) in X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in - let message' = X_option.map (fun x -> ("message " , `String (x ()))) message in + let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ]) let error title message () = mk_error ~title:(title) ~message:(message) () @@ -467,12 +467,26 @@ module Assert = struct end let json_of_error = J.to_string + let error_pp out (e : error) = let open JSON_string_utils in - let message = e |> member "message" |> string || "(no message)" in - let title = e |> member "title" |> string || "(no title)" in - let error_code = e |> member "error_code" |> int |> string_of_int || "no error code" in - Format.fprintf out "%s (%s): %s" title error_code message + let message = e |> member "message" |> J.to_string in + let error_code = + let error_code = e |> member "error_code" in + match error_code with + | `Null -> "" + | _ -> " (" ^ (J.to_string error_code) ^ ")" in + let title = e |> member "title" |> J.to_string in + let data = + let data = e |> member "data" in + match data with + | `Null -> "" + | _ -> J.to_string data in + Format.fprintf out "%s (%s): %s. %s" title error_code message data + +(* let error_pp out (e : error) = + * Format.fprintf out "%s" @@ json_of_error e *) + let error_pp_short out (e : error) = let open JSON_string_utils in diff --git a/vendors/ligo-utils/simple-utils/x_option.ml b/vendors/ligo-utils/simple-utils/x_option.ml index b538b7028..ad69d5303 100644 --- a/vendors/ligo-utils/simple-utils/x_option.ml +++ b/vendors/ligo-utils/simple-utils/x_option.ml @@ -27,8 +27,7 @@ let to_list = function | None -> [] | Some x -> [ x ] let collapse_list = fun l -> - List.concat - @@ List.map to_list l + List.concat @@ List.map to_list l (* Combinators *) let bind_eager_or = fun a b -> match (a , b) with From 055bee804eb851ed0f3f4497641e528fc92e1e99 Mon Sep 17 00:00:00 2001 From: Galfour Date: Fri, 31 May 2019 22:03:06 +0000 Subject: [PATCH 6/8] fix ligodity issues --- src/contracts/counter.mligo | 2 +- src/contracts/type-alias.ligo | 3 + src/main/contract.ml | 204 ---------------------------------- src/parser/ligodity.ml | 19 ++-- src/parser/ligodity/AST.mli | 1 + src/simplify/ligodity.ml | 43 ++++++- src/test/integration_tests.ml | 9 +- src/typer/typer.ml | 29 +++-- 8 files changed, 83 insertions(+), 227 deletions(-) create mode 100644 src/contracts/type-alias.ligo delete mode 100644 src/main/contract.ml diff --git a/src/contracts/counter.mligo b/src/contracts/counter.mligo index 0cfa95bdf..b15f67905 100644 --- a/src/contracts/counter.mligo +++ b/src/contracts/counter.mligo @@ -1,4 +1,4 @@ type storage = int let%entry main (p:int) storage = - (list [] : operation list , p + storage) + ((list [] : operation list) , p + storage) diff --git a/src/contracts/type-alias.ligo b/src/contracts/type-alias.ligo new file mode 100644 index 000000000..c62b15f9e --- /dev/null +++ b/src/contracts/type-alias.ligo @@ -0,0 +1,3 @@ +type toto is int + +const foo : toto = 23 \ No newline at end of file diff --git a/src/main/contract.ml b/src/main/contract.ml deleted file mode 100644 index 84f856c7c..000000000 --- a/src/main/contract.ml +++ /dev/null @@ -1,204 +0,0 @@ -open Trace - -include struct - open Ast_simplified - - let assert_entry_point_defined : program -> string -> unit result = - fun program entry_point -> - let aux : declaration -> bool = fun declaration -> - match declaration with - | Declaration_type _ -> false - | Declaration_constant (name , _ , _) -> name = entry_point - in - trace_strong (simple_error "no entry-point with given name") @@ - Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program -end - -include struct - open Ast_typed - open Combinators - - let get_entry_point_type : type_value -> (type_value * type_value) result = fun t -> - let%bind (arg , result) = - trace_strong (simple_error "entry-point doesn't have a function type") @@ - get_t_function t in - let%bind (arg' , storage_param) = - trace_strong (simple_error "entry-point doesn't have 2 parameters") @@ - get_t_pair arg in - let%bind (ops , storage_result) = - trace_strong (simple_error "entry-point doesn't have 2 results") @@ - get_t_pair result in - let%bind () = - trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@ - assert_t_list_operation ops in - let%bind () = - trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@ - assert_type_value_eq (storage_param , storage_result) in - ok (arg' , storage_param) - - let get_entry_point : program -> string -> (type_value * type_value) result = fun p e -> - let%bind declaration = get_declaration_by_name p e in - match declaration with - | Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation - - let assert_valid_entry_point = fun p e -> - let%bind _ = get_entry_point p e in - ok () -end - -let transpile_value - (e:Ast_typed.annotated_expression) : Mini_c.value result = - let%bind f = - let open Transpiler in - let (f , _) = functionalize e in - let%bind main = translate_main f in - ok main - in - - let input = Mini_c.Combinators.d_unit in - let%bind r = Run_mini_c.run_entry f input in - ok r - -let parsify_pascaligo = fun source -> - let%bind raw = - trace (simple_error "parsing") @@ - Parser.Pascaligo.parse_file source in - let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Pascaligo.simpl_program raw in - ok simplified - -let parsify_expression_pascaligo = fun source -> - let%bind raw = - trace (simple_error "parsing expression") @@ - Parser.Pascaligo.parse_expression source in - let%bind simplified = - trace (simple_error "simplifying expression") @@ - Simplify.Pascaligo.simpl_expression raw in - ok simplified - -let parsify_ligodity = fun source -> - let%bind raw = - trace (simple_error "parsing") @@ - Parser.Ligodity.parse_file source in - let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Ligodity.simpl_program raw in - ok simplified - -let parsify_expression_ligodity = fun source -> - let%bind raw = - trace (simple_error "parsing expression") @@ - Parser.Ligodity.parse_expression source in - let%bind simplified = - trace (simple_error "simplifying expression") @@ - Simplify.Ligodity.simpl_expression raw in - ok simplified - -let parsify = fun syntax source -> - let%bind parsify = match syntax with - | "pascaligo" -> ok parsify_pascaligo - | "cameligo" -> ok parsify_ligodity - | _ -> simple_fail "unrecognized parser" - in - parsify source - -let parsify_expression = fun syntax source -> - let%bind parsify = match syntax with - | "pascaligo" -> ok parsify_expression_pascaligo - | "cameligo" -> ok parsify_expression_ligodity - | _ -> simple_fail "unrecognized parser" - in - parsify source - -let compile_contract_file : string -> string -> string -> string result = fun source entry_point syntax -> - let%bind simplified = parsify syntax source in - let%bind () = - assert_entry_point_defined simplified entry_point in - let%bind typed = - trace (simple_error "typing") @@ - Typer.type_program simplified in - let%bind mini_c = - trace (simple_error "transpiling") @@ - Transpiler.translate_entry typed entry_point in - let%bind michelson = - trace (simple_error "compiling") @@ - Compiler.translate_contract mini_c in - let str = - Format.asprintf "%a" Michelson.pp_stripped michelson in - ok str - -let compile_contract_parameter : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> - let%bind (program , parameter_tv) = - let%bind simplified = parsify syntax source in - let%bind () = - assert_entry_point_defined simplified entry_point in - let%bind typed = - trace (simple_error "typing file") @@ - Typer.type_program simplified in - let%bind (param_ty , _) = - get_entry_point typed entry_point in - ok (typed , param_ty) - in - let%bind expr = - let%bind typed = - let%bind simplified = parsify_expression syntax expression in - let env = - let last_declaration = Location.unwrap List.(hd @@ rev program) in - match last_declaration with - | Declaration_constant (_ , (_ , post_env)) -> post_env - in - trace (simple_error "typing expression") @@ - Typer.type_expression env simplified in - let%bind () = - trace (simple_error "expression type doesn't match type parameter") @@ - Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in - let%bind mini_c = - trace (simple_error "transpiling expression") @@ - transpile_value typed in - let%bind michelson = - trace (simple_error "compiling expression") @@ - Compiler.translate_value mini_c in - let str = - Format.asprintf "%a" Michelson.pp_stripped michelson in - ok str - in - ok expr - - -let compile_contract_storage : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> - let%bind (program , storage_tv) = - let%bind simplified = parsify syntax source in - let%bind () = - assert_entry_point_defined simplified entry_point in - let%bind typed = - trace (simple_error "typing file") @@ - Typer.type_program simplified in - let%bind (_ , storage_ty) = - get_entry_point typed entry_point in - ok (typed , storage_ty) - in - let%bind expr = - let%bind simplified = parsify_expression syntax expression in - let%bind typed = - let env = - let last_declaration = Location.unwrap List.(hd @@ rev program) in - match last_declaration with - | Declaration_constant (_ , (_ , post_env)) -> post_env - in - trace (simple_error "typing expression") @@ - Typer.type_expression env simplified in - let%bind () = - trace (simple_error "expression type doesn't match type storage") @@ - Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in - let%bind mini_c = - trace (simple_error "transpiling expression") @@ - transpile_value typed in - let%bind michelson = - trace (simple_error "compiling expression") @@ - Compiler.translate_value mini_c in - let str = - Format.asprintf "%a" Michelson.pp_stripped michelson in - ok str - in - ok expr diff --git a/src/parser/ligodity.ml b/src/parser/ligodity.ml index 9d49908b6..81ee4183e 100644 --- a/src/parser/ligodity.ml +++ b/src/parser/ligodity.ml @@ -4,15 +4,18 @@ module Parser = Parser_ligodity.Parser module AST = Parser_ligodity.AST let parse_file (source: string) : AST.t result = + (* let pp_input = + * let prefix = Filename.(source |> basename |> remove_extension) + * and suffix = ".pp.ligo" + * in prefix ^ suffix in *) + + (* let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" + * source pp_input in + * let%bind () = sys_command cpp_cmd in *) + let pp_input = - let prefix = Filename.(source |> basename |> remove_extension) - and suffix = ".pp.ligo" - in prefix ^ suffix in - - let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" - source pp_input in - let%bind () = sys_command cpp_cmd in - + source + in let%bind channel = generic_try (simple_error "error opening file") @@ (fun () -> open_in pp_input) in diff --git a/src/parser/ligodity/AST.mli b/src/parser/ligodity/AST.mli index f23b40375..d235b72f4 100644 --- a/src/parser/ligodity/AST.mli +++ b/src/parser/ligodity/AST.mli @@ -486,3 +486,4 @@ val unpar : expr -> expr val print_projection : projection -> unit val print_pattern : pattern -> unit +val print_expr : expr -> unit diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index 0c3398758..168980383 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -100,6 +100,14 @@ let rec simpl_expression : let mk_let_in binder rhs result = E_let_in {binder; rhs; result} in + trace ( + let title () = "simplifying expression" in + let message () = "" in + let data = [ + ("expression" , thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t) + ] in + error ~data title message + ) @@ match t with | Raw.ELetIn e -> ( let Raw.{binding; body; _} = e.value in @@ -194,7 +202,7 @@ let rec simpl_expression : | EString _ -> simple_fail "string: not supported yet" | ELogic l -> simpl_logic_expression ?te_annot l | EList l -> simpl_list_expression ?te_annot l - | ECase c -> + | ECase c -> ( let%bind e = simpl_expression c.value.expr in let%bind lst = let aux (x : Raw.expr Raw.case_clause) = @@ -204,8 +212,31 @@ let rec simpl_expression : @@ List.map aux @@ List.map get_value @@ npseq_to_list c.value.cases.value in - let%bind cases = simpl_cases lst in - return @@ E_matching (e, cases) + let default_action () = + let%bind cases = simpl_cases lst in + return @@ E_matching (e , cases) in + (* Hack to take care of patterns introduced by `parser/ligodity/Parser.mly` in "norm_fun_expr" *) + match lst with + | [ (pattern , rhs) ] -> ( + match pattern with + | Raw.PPar p -> ( + let p' = p.value.inside in + match p' with + | Raw.PTyped x -> ( + let x' = x.value in + match x'.pattern with + | Raw.PVar y -> + let var_name = y.value in + let%bind type_expr = simpl_type_expression x'.type_expr in + return @@ e_let_in (var_name , Some type_expr) e rhs + | _ -> default_action () + ) + | _ -> default_action () + ) + | _ -> default_action () + ) + | _ -> default_action () + ) | EFun lamb -> let%bind input_type = bind_map_option (fun (_,type_expr) -> simpl_type_expression type_expr) @@ -237,6 +268,8 @@ let rec simpl_expression : let%bind match_true = simpl_expression c.ifso in let%bind match_false = simpl_expression c.ifnot in return @@ E_matching (expr, (Match_bool {match_true; match_false})) + + and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = let return x = ok @@ make_option_typed x te_annot in match t with @@ -302,7 +335,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu let {name;type_expr} : Raw.type_decl = x.value in let%bind type_expression = simpl_type_expression type_expr in ok @@ loc x @@ Declaration_type (name.value , type_expression) - | LetEntry _ -> simple_fail "no entry point yet" + | LetEntry x (* -> simple_fail "no entry point yet" *) | Let x -> ( let _, binding = x.value in let {variable ; lhs_type ; let_rhs} = binding in @@ -392,4 +425,4 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching 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 @@ List.rev @@ nseq_to_list t.decl diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index ccf47465b..6f8a947f7 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -4,9 +4,13 @@ open Test_helpers open Ast_simplified.Combinators -let mtype_file = type_file "cameligo" +let mtype_file ?debug_simplify ?debug_typed = type_file ?debug_simplify ?debug_typed "cameligo" let type_file = type_file "pascaligo" +let type_alias () : unit result = + let%bind program = type_file "./contracts/type-alias.ligo" in + expect_eq_evaluate program "foo" (e_int 23) + let function_ () : unit result = let%bind program = type_file "./contracts/function.ligo" in let make_expect = fun n -> n in @@ -436,7 +440,7 @@ let dispatch_counter_contract () : unit result = expect_eq_n program "main" make_input make_expected let basic_mligo () : unit result = - let%bind typed = mtype_file "./contracts/basic.mligo" in + let%bind typed = mtype_file ~debug_simplify:true "./contracts/basic.mligo" in let%bind result = evaluate_typed "foo" typed in Ligo.AST_Typed.assert_value_eq (Ligo.AST_Typed.Combinators.e_a_empty_int (42 + 127), result) @@ -453,6 +457,7 @@ let guess_the_hash_mligo () : unit result = expect_eq_n program "main" make_input make_expected let main = "Integration (End to End)", [ + test "type alias" type_alias ; test "function" function_ ; test "assign" assign ; test "declaration local" declaration_local ; diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 70b1df25f..0567be391 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -357,16 +357,31 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a } -> ( let%bind input_type = let%bind input_type = - trace_option (simple_error "no input type provided") @@ - input_type in + (* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *) + let default_action () = simple_fail "no input type provided" in + match input_type with + | Some ty -> ok ty + | None -> ( + match result with + | I.E_let_in li -> ( + match li.rhs with + | I.E_variable name when name = (fst binder) -> ( + match snd li.binder with + | Some ty -> ok ty + | None -> default_action () + ) + | _ -> default_action () + ) + | _ -> default_action () + ) + in evaluate_type e input_type in let%bind output_type = - let%bind output_type = - trace_option (simple_error "no output type provided") @@ - output_type in - evaluate_type e output_type in + bind_map_option (evaluate_type e) output_type + in let e' = Environment.add_ez_binder (fst binder) input_type e in - let%bind result = type_expression ~tv_opt:output_type e' result in + let%bind result = type_expression ?tv_opt:output_type e' result in + let output_type = result.type_annotation in return (E_lambda {binder = fst binder;input_type;output_type;result}) (t_function input_type output_type ()) ) | E_constant (name, lst) -> From 8d6f19ac6ca9dac3b5d6cc39df4ed9e42b6e617b Mon Sep 17 00:00:00 2001 From: Galfour Date: Sat, 1 Jun 2019 08:37:43 +0000 Subject: [PATCH 7/8] very unstable state --- src/parser/ligodity/AST.ml | 6 +- src/parser/ligodity/AST.mli | 2 +- src/parser/ligodity/Parser.mly | 146 ++------------------------------- src/simplify/ligodity.ml | 59 +++++++++---- src/simplify/pascaligo.ml | 1 - 5 files changed, 56 insertions(+), 158 deletions(-) diff --git a/src/parser/ligodity/AST.ml b/src/parser/ligodity/AST.ml index 749db38ef..7da14760e 100644 --- a/src/parser/ligodity/AST.ml +++ b/src/parser/ligodity/AST.ml @@ -116,7 +116,7 @@ and declaration = (* Non-recursive values *) and let_binding = { - variable : variable; + bindings : pattern list; lhs_type : (colon * type_expr) option; eq : equal; let_rhs : expr @@ -544,8 +544,8 @@ and print_terminator = function Some semi -> print_token semi ";" | None -> () -and print_let_binding {variable; lhs_type; eq; let_rhs} = - print_var variable; +and print_let_binding {bindings; lhs_type; eq; let_rhs} = + List.iter print_pattern bindings; (match lhs_type with None -> () | Some (colon, type_expr) -> diff --git a/src/parser/ligodity/AST.mli b/src/parser/ligodity/AST.mli index d235b72f4..ea400b6d5 100644 --- a/src/parser/ligodity/AST.mli +++ b/src/parser/ligodity/AST.mli @@ -125,7 +125,7 @@ and declaration = (* Non-recursive values *) and let_binding = { (* p = e p : t = e *) - variable : variable; + bindings : pattern list; lhs_type : (colon * type_expr) option; eq : equal; let_rhs : expr diff --git a/src/parser/ligodity/Parser.mly b/src/parser/ligodity/Parser.mly index 88f191f51..a492f2624 100644 --- a/src/parser/ligodity/Parser.mly +++ b/src/parser/ligodity/Parser.mly @@ -42,142 +42,9 @@ let rec sub_rec fresh path (map, rank) pattern = let map' = split fresh map path' pattern in map', rank+1 -and split fresh map path = function - PTuple t -> let apply = sub_rec fresh path in - Utils.nsepseq_foldl apply (map,1) t.value |> fst -| PPar p -> split fresh map path p.value.inside -| PVar v -> if VMap.mem v.value map - then - let err = - Region.{value="Non-linear pattern."; region=v.region} - in (Lexer.prerr ~kind:"Syntactical" err; exit 1) - else - let proj = mk_projection fresh path - in VMap.add v.value (None, proj) map -| PWild _ -> map -| PUnit _ -> let anon = Utils.gen_sym () in - let unit = ghost, TAlias (ghost_of "unit") - and proj = mk_projection fresh path - in VMap.add anon (Some unit, proj) map -| PRecord {region; _} -| PConstr {region; _} -| PTyped {region; _} -> - let err = Region.{value="Not implemented yet."; region} - in (Lexer.prerr ~kind:"Syntactical" err; exit 1) -| p -> let _, _, map = split_pattern p in map - -and split_pattern = function - PPar p -> split_pattern p.value.inside -| PVar v -> v, None, VMap.empty -| PWild _ -> Utils.gen_sym () |> ghost_of, None, VMap.empty -| PUnit _ -> let fresh = Utils.gen_sym () |> ghost_of in - let unit = TAlias (ghost_of "unit") - in fresh, Some unit, VMap.empty -| PTyped {value=p; _} -> - let var', type', map = split_pattern p.pattern in - (match type' with - None -> var', Some p.type_expr, map - | Some t when t = p.type_expr -> var', Some t, map (* hack *) - | Some t -> fail_syn_unif t p.type_expr) -| PTuple t -> - let fresh = Utils.gen_sym () |> ghost_of - and init = VMap.empty, 1 in - let apply (map, rank) pattern = - split fresh map (rank,[]) pattern, rank+1 in - let map = Utils.nsepseq_foldl apply init t.value |> fst - in fresh, None, map -| PRecord {region; _} -| PConstr {region; _} -> - let err = Region.{value="Not implemented yet."; region} - in (Lexer.prerr ~kind:"Syntactical" err; exit 1) -| PInt {region; _} | PTrue region -| PFalse region | PString {region; _} -| PList Sugar {region; _} | PList PCons {region; _} -> - let err = Region.{value="Incomplete pattern."; region} - in (Lexer.prerr ~kind:"Syntactical" err; exit 1) - -let mk_let_bindings = - let apply var (lhs_type, proj) = - let new_bind = { - variable = ghost_of var; - lhs_type; - eq = ghost; - let_rhs = EProj (ghost_of proj)} in - let new_let = Let (ghost_of (ghost, new_bind)) - in Utils.nseq_cons new_let - in VMap.fold apply - -let mk_let_in_bindings = - let apply var (lhs_type, proj) acc = - let binding = { - variable = ghost_of var; - lhs_type; - eq = ghost; - let_rhs = EProj (ghost_of proj)} in - let let_in = { - kwd_let = ghost; - binding; - kwd_in = ghost; - body = acc} - in ELetIn (ghost_of let_in) - in VMap.fold apply (* We rewrite "fun p -> e" into "fun x -> match x with p -> e" *) -let norm_fun_expr patterns expr = - let apply pattern expr = - match pattern with - PVar var -> - let fun_expr = { - kwd_fun = ghost; - param = var; - p_annot = None; - arrow = ghost; - body = expr} - in EFun (ghost_of fun_expr) - | PTyped p -> - let pattern = p.value.pattern - and type_expr = p.value.type_expr in - let fresh = Utils.gen_sym () |> ghost_of in - let clause = {pattern; arrow=ghost; rhs=expr} in - let clause = ghost_of clause in - let cases = ghost_of (clause, []) in - let case = { - kwd_match = ghost; - expr = EVar fresh; - opening = With ghost; - lead_vbar = None; - cases; - closing = End ghost} in - let case = ECase (ghost_of case) in - let fun_expr = { - kwd_fun = ghost; - param = fresh; - p_annot = Some (p.value.colon, type_expr); - arrow = ghost; - body = case} - in EFun (ghost_of fun_expr) - | _ -> let fresh = Utils.gen_sym () |> ghost_of in - let clause = {pattern; arrow=ghost; rhs=expr} in - let clause = ghost_of clause in - let cases = ghost_of (clause, []) in - let case = { - kwd_match = ghost; - expr = EVar fresh; - opening = With ghost; - lead_vbar = None; - cases; - closing = End ghost} in - let case = ECase (ghost_of case) in - let fun_expr = { - kwd_fun = ghost; - param = fresh; - p_annot = None; - arrow = ghost; - body = case} - in EFun (ghost_of fun_expr) - in Utils.nseq_foldr apply patterns expr - (* END HEADER *) %} @@ -416,11 +283,11 @@ field_decl: entry_binding: ident nseq(sub_irrefutable) type_annotation? eq expr { - let let_rhs = norm_fun_expr $2 $5 in - {variable = $1; lhs_type=$3; eq=$4; let_rhs} + let let_rhs = $5 in + {bindings = ($1 , $2); lhs_type=$3; eq=$4; let_rhs} } | ident type_annotation? eq fun_expr(expr) { - {variable = $1; lhs_type=$2; eq=$3; let_rhs=$4} } + {bindings = ($1 , []); lhs_type=$2; eq=$3; let_rhs=$4} } (* Top-level non-recursive definitions *) @@ -428,14 +295,15 @@ let_declaration: reg(kwd(Let) let_binding {$1,$2}) { let kwd_let, (binding, map) = $1.value in let let0 = Let {$1 with value = kwd_let, binding} - in mk_let_bindings map (let0,[]) + in + mk_let_bindings map (let0,[]) } let_binding: ident nseq(sub_irrefutable) type_annotation? eq expr { - let let_rhs = norm_fun_expr $2 $5 in + let let_rhs = $5 in let map = VMap.empty in - {variable=$1; lhs_type=$3; eq=$4; let_rhs}, map + {bindings= ($1 , $2); lhs_type=$3; eq=$4; let_rhs}, map } | irrefutable type_annotation? eq expr { let variable, type_opt, map = split_pattern $1 in diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index 168980383..9381fb251 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -237,20 +237,7 @@ let rec simpl_expression : ) | _ -> default_action () ) - | EFun lamb -> - let%bind input_type = bind_map_option - (fun (_,type_expr) -> simpl_type_expression type_expr) - lamb.value.p_annot in - let body, body_type = - match lamb.value.body with - EAnnot {value = expr, type_expr} -> expr, Some type_expr - | expr -> expr, None in - let%bind output_type = - bind_map_option simpl_type_expression body_type in - let%bind result = simpl_expression body in - let binder = lamb.value.param.value, input_type in - let lambda = {binder; input_type; output_type; result = result} - in return @@ E_lambda lambda + | EFun lamb -> simpl_fun lamb | ESeq s -> let items : Raw.expr list = pseq_to_list s.value.elements in (match items with @@ -269,6 +256,50 @@ let rec simpl_expression : let%bind match_false = simpl_expression c.ifnot in return @@ E_matching (expr, (Match_bool {match_true; match_false})) +and simpl_fun lamb : expr result = + let return x = ok x in + let rec aux args body = + match body with + | Raw.EFun l -> ( + let l' = l.value in + let annot = Option.map snd l'.p_annot in + aux (args @ [(l'.param.value , annot)]) l'.body + ) + | _ -> (args , body) in + let (args , body) = aux [] (Raw.EFun lamb) in + let%bind args' = + let aux = fun (name , ty_opt) -> + let%bind ty = + match ty_opt with + | Some ty -> simpl_type_expression ty + | None when name = "storage" -> ok (T_variable "storage") + | None -> simple_fail "missing type annotation on input" + in + ok (name , ty) + in + bind_map_list aux args + in + let arguments_name = "arguments" in + let (binder , input_type) = + let type_expression = T_tuple (List.map snd args') in + (arguments_name , type_expression) in + let body, body_type = + match body with + | EAnnot {value = expr, type_expr} -> expr, Some type_expr + | expr -> expr, None in + let%bind output_type = + bind_map_option simpl_type_expression body_type in + let%bind result = simpl_expression body in + let wrapped_result = + let aux = fun i (name , ty) wrapped -> + let accessor = E_accessor (E_variable arguments_name , [ Access_tuple i ]) in + e_let_in (name , Some ty) accessor wrapped + in + let wraps = List.mapi aux args' in + List.fold_right' (fun x f -> f x) result wraps in + let lambda = {binder = (binder , Some input_type); input_type = (Some input_type); output_type; result = wrapped_result} + in return @@ E_lambda lambda + and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = let return x = ok @@ make_option_typed x te_annot in diff --git a/src/simplify/pascaligo.ml b/src/simplify/pascaligo.ml index bf907b1fb..038fd4484 100644 --- a/src/simplify/pascaligo.ml +++ b/src/simplify/pascaligo.ml @@ -351,7 +351,6 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e let arguments_name = "arguments" in let%bind params = bind_map_list simpl_param lst in let (binder , input_type) = - (* let type_expression = T_record (SMap.of_list params) in *) let type_expression = T_tuple (List.map snd params) in (arguments_name , type_expression) in let%bind tpl_declarations = From a7298dc16d08c4977cdc89b5a84ce83571f3981d Mon Sep 17 00:00:00 2001 From: Galfour Date: Sat, 1 Jun 2019 11:51:49 +0000 Subject: [PATCH 8/8] fix cli.ml --- src/bin/cli.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 7e3873d48..81480236e 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -47,7 +47,7 @@ let compile_file = toplevel @@ let%bind contract = trace (simple_error "compile michelson") @@ - Ligo.Contract.compile_contract_file source entry_point syntax in + Ligo.Run.compile_contract_file source entry_point syntax in Format.printf "Contract:\n%s\n" contract ; ok () in @@ -61,7 +61,7 @@ let compile_parameter = toplevel @@ let%bind value = trace (simple_error "compile-input") @@ - Ligo.Contract.compile_contract_parameter source entry_point expression syntax in + Ligo.Run.compile_contract_parameter source entry_point expression syntax in Format.printf "Input:\n%s\n" value; ok () in @@ -75,7 +75,7 @@ let compile_storage = toplevel @@ let%bind value = trace (simple_error "compile-storage") @@ - Ligo.Contract.compile_contract_storage source entry_point expression syntax in + Ligo.Run.compile_contract_storage source entry_point expression syntax in Format.printf "Storage:\n%s\n" value; ok () in