diff --git a/src/lib_utils/location.ml b/src/lib_utils/location.ml index 825cdd0bb..8c85c9ee8 100644 --- a/src/lib_utils/location.ml +++ b/src/lib_utils/location.ml @@ -1,24 +1,24 @@ -type file_location = { - filename : string ; - start_line : int ; - start_column : int ; - end_line : int ; - end_column : int ; -} +(* type file_location = { *) +(* filename : string ; *) +(* start_line : int ; *) +(* start_column : int ; *) +(* end_line : int ; *) +(* end_column : int ; *) +(* } *) type virtual_location = string type t = - | File of file_location + | File of Region.t (* file_location *) | Virtual of virtual_location let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = - let filename = start_pos.pos_fname in - let start_line = start_pos.pos_lnum in - let end_line = end_pos.pos_lnum in - let start_column = start_pos.pos_cnum - start_pos.pos_bol in - let end_column = end_pos.pos_cnum - end_pos.pos_bol in - File { filename ; start_line ; start_column ; end_line ; end_column } + (* TODO: give correct unicode offsets (the random number is here so + that searching for wrong souce locations appearing in messages + will quickly lead here *) + File (Region.make + ~start:(Pos.make ~byte:start_pos ~point_num:(-1897000) ~point_bol:(-1897000)) + ~stop:(Pos.make ~byte:end_pos ~point_num:(-1897000) ~point_bol:(-1897000))) let virtual_location s = Virtual s let dummy = virtual_location "dummy" diff --git a/src/ligo/ligo_parser/Pos.ml b/src/lib_utils/pos.ml similarity index 100% rename from src/ligo/ligo_parser/Pos.ml rename to src/lib_utils/pos.ml diff --git a/src/ligo/ligo_parser/Pos.mli b/src/lib_utils/pos.mli similarity index 100% rename from src/ligo/ligo_parser/Pos.mli rename to src/lib_utils/pos.mli diff --git a/src/ligo/ligo_parser/Region.ml b/src/lib_utils/region.ml similarity index 100% rename from src/ligo/ligo_parser/Region.ml rename to src/lib_utils/region.ml diff --git a/src/ligo/ligo_parser/Region.mli b/src/lib_utils/region.mli similarity index 100% rename from src/ligo/ligo_parser/Region.mli rename to src/lib_utils/region.mli diff --git a/src/lib_utils/tezos_utils.ml b/src/lib_utils/tezos_utils.ml index aecd41270..efa7804e7 100644 --- a/src/lib_utils/tezos_utils.ml +++ b/src/lib_utils/tezos_utils.ml @@ -21,3 +21,5 @@ module Map = X_map module Dictionary = Dictionary module Environment = Environment module Tree = Tree +module Region = Region +module Pos = Pos 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/ligo_parser/LexToken.mli b/src/ligo/ligo_parser/LexToken.mli index ebf887861..f2c8c8ba7 100644 --- a/src/ligo/ligo_parser/LexToken.mli +++ b/src/ligo/ligo_parser/LexToken.mli @@ -21,6 +21,9 @@ aliased to [token]. *) +module Region = Tezos_utils.Region +module Pos = Tezos_utils.Pos + type lexeme = string (* TOKENS *) diff --git a/src/ligo/ligo_parser/LexToken.mll b/src/ligo/ligo_parser/LexToken.mll index 1bc88a695..a2ba351e7 100644 --- a/src/ligo/ligo_parser/LexToken.mll +++ b/src/ligo/ligo_parser/LexToken.mll @@ -9,8 +9,10 @@ type lexeme = string let sprintf = Printf.sprintf -module SMap = Utils.String.Map -module SSet = Utils.String.Set +module Region = Tezos_utils.Region +module Pos = Tezos_utils.Pos +module SMap = Utils.String.Map +module SSet = Utils.String.Set (* Hack to roll back one lexeme in the current semantic action *) (* diff --git a/src/ligo/ligo_parser/Markup.ml b/src/ligo/ligo_parser/Markup.ml index 5f379b47b..a25e78754 100644 --- a/src/ligo/ligo_parser/Markup.ml +++ b/src/ligo/ligo_parser/Markup.ml @@ -1,3 +1,5 @@ +module Region = Tezos_utils.Region + type lexeme = string type t = diff --git a/src/ligo/ligo_parser/Markup.mli b/src/ligo/ligo_parser/Markup.mli index e9c525893..93ffe2c2c 100644 --- a/src/ligo/ligo_parser/Markup.mli +++ b/src/ligo/ligo_parser/Markup.mli @@ -1,6 +1,8 @@ (* This module defines the sorts of markup recognised by the LIGO lexer *) +module Region = Tezos_utils.Region + (* A lexeme is piece of concrete syntax belonging to a token. In algebraic terms, a token is also a piece of abstract lexical syntax. Lexical units emcompass both markup and lexemes. *) 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 742d09161..d87c25910 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 = @@ -364,7 +367,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 = @@ -391,7 +394,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 ()) @@