From f8090e4b3e2a071e06337ad331b9a7e943d01311 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 15 Apr 2019 18:32:15 +0200 Subject: [PATCH] Threaded the srcloc for top-level declarations until transpiler.ml --- src/ligo/ast_simplified.ml | 4 ++-- src/ligo/ast_typed.ml | 6 +++--- src/ligo/simplify.ml | 11 ++++++----- src/ligo/simplify_multifix.ml | 2 +- src/ligo/transpiler.ml | 7 +++++-- src/ligo/typer.ml | 9 +++++---- 6 files changed, 22 insertions(+), 17 deletions(-) diff --git a/src/ligo/ast_simplified.ml b/src/ligo/ast_simplified.ml index 855f13082..5511255ad 100644 --- a/src/ligo/ast_simplified.ml +++ b/src/ligo/ast_simplified.ml @@ -6,7 +6,7 @@ type type_name = string type 'a name_map = 'a SMap.t type 'a type_name_map = 'a SMap.t -type program = declaration list +type program = declaration Location.wrap list and declaration = | Declaration_type of named_type_expression @@ -214,7 +214,7 @@ module PP = struct fprintf ppf "const %s = %a" name annotated_expression ae let program ppf (p:program) = - fprintf ppf "@[%a@]" (list_sep declaration (tag "@;")) p + fprintf ppf "@[%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p) end module Rename = struct diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index 14ee17375..98b01d6dc 100644 --- a/src/ligo/ast_typed.ml +++ b/src/ligo/ast_typed.ml @@ -8,7 +8,7 @@ type type_name = string type 'a name_map = 'a SMap.t type 'a type_name_map = 'a SMap.t -type program = declaration list +type program = declaration Location.wrap list and declaration = | Declaration_constant of named_expression @@ -136,7 +136,7 @@ let get_entry (p:program) (entry : string) : annotated_expression result = in let%bind result = trace_option (simple_error "no entry point with given name") @@ - Tezos_utils.List.find_map aux p in + Tezos_utils.List.find_map aux (List.map Location.unwrap p) in ok result let get_functional_entry (p:program) (entry : string) : (lambda * type_value) result = @@ -245,7 +245,7 @@ module PP = struct fprintf ppf "const %s = %a" name annotated_expression ae let program ppf (p:program) = - fprintf ppf "@[%a@]" (list_sep declaration (tag "@;")) p + fprintf ppf "@[%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p) end diff --git a/src/ligo/simplify.ml b/src/ligo/simplify.ml index ae988aa49..f4410fdc6 100644 --- a/src/ligo/simplify.ml +++ b/src/ligo/simplify.ml @@ -292,19 +292,20 @@ and simpl_param : Raw.param_decl -> named_type_expression result = fun t -> let%bind type_expression = simpl_type_expression c.param_type in ok { type_name ; type_expression } -and simpl_declaration : Raw.declaration -> declaration result = fun t -> +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 let%bind type_expression = simpl_type_expression type_expr in - ok @@ Declaration_type {type_name=name.value;type_expression} + ok @@ loc x @@ Declaration_type {type_name=name.value;type_expression} | ConstDecl x -> let {name;const_type;init} = x.value in let%bind expression = simpl_expression init in let%bind t = simpl_type_expression const_type in let type_annotation = Some t in - ok @@ Declaration_constant {name=name.value;annotated_expression={expression with type_annotation}} + ok @@ loc x @@ Declaration_constant {name=name.value;annotated_expression={expression with type_annotation}} | LambdaDecl (FunDecl x) -> let {name;param;ret_type;local_decls;block;return} : fun_decl = x.value in (match npseq_to_list param.value.inside with @@ -329,7 +330,7 @@ and simpl_declaration : Raw.declaration -> declaration result = fun t -> let type_annotation = Some (T_function (input_type, output_type)) in Declaration_constant {name;annotated_expression = {expression;type_annotation}} in - ok decl + ok @@ loc x @@ decl ) | lst -> ( let%bind params = bind_map_list simpl_param lst in @@ -371,7 +372,7 @@ and simpl_declaration : Raw.declaration -> declaration result = fun t -> let type_annotation = Some (T_function (input_type, output_type)) in Declaration_constant {name = name.value;annotated_expression = {expression;type_annotation}} in - ok decl + ok @@ loc x @@ decl ) ) | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet" diff --git a/src/ligo/simplify_multifix.ml b/src/ligo/simplify_multifix.ml index 0d7e5dfac..f4ab0dc77 100644 --- a/src/ligo/simplify_multifix.ml +++ b/src/ligo/simplify_multifix.ml @@ -196,7 +196,7 @@ let statement : I.statement -> O.declaration result = fun s -> ok @@ O.Declaration_type {type_name = unwrap n ; type_expression = unwrap te'} let program : I.program -> O.program result = fun (Program lst) -> - bind_map_list (apply Location.unwrap >| bind_map_location statement) lst + bind_map_list (bind_map_location statement) lst let main : I.entry_point -> O.program Location.wrap result = bind_map_location program diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index 82ff5d5e9..7d893b894 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -5,6 +5,9 @@ open Combinators module AST = Ast_typed open AST.Combinators +let temp_unwrap_loc = Location.unwrap +let temp_unwrap_loc_list = List.map Location.unwrap + let list_of_map m = List.rev @@ Map.String.fold (fun _ v prev -> v :: prev) m [] let kv_list_of_map m = List.rev @@ Map.String.fold (fun k v prev -> (k, v) :: prev) m [] let map_of_kv_list lst = @@ -367,7 +370,7 @@ let translate_program (lst:AST.program) : program result = let%bind ((_, env') as cur') = translate_declaration env cur in ok (cur' :: tl, env'.post_environment) in - let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) lst in + let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in ok statements let translate_main (l:AST.lambda) (t:AST.type_value) : anon_function result = @@ -394,7 +397,7 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result = match lst with | [] -> None | hd :: tl -> ( - let AST.Declaration_constant an = hd in + let AST.Declaration_constant an = temp_unwrap_loc hd in if an.name = name then ( match an.annotated_expression.expression with diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index fb28635c9..0d12eac09 100644 --- a/src/ligo/typer.ml +++ b/src/ligo/typer.ml @@ -96,13 +96,14 @@ module Errors = struct end open Errors - let rec type_program (p:I.program) : O.program result = - let aux (e, acc:(environment * O.declaration list)) (d:I.declaration) = - let%bind (e', d') = type_declaration e d in + let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = + let%bind ed' = (bind_map_location (type_declaration e)) d in + let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in + let (e', d') = Location.unwrap ed' in match d' with | None -> ok (e', acc) - | Some d' -> ok (e', d' :: acc) + | Some d' -> ok (e', loc ed' d' :: acc) in let%bind (_, lst) = trace (fun () -> program_error p ()) @@