Merge branch 'master' of gitlab.com:gabriel.alfour/tezos

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"

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

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 "@[<v>%a@]" (list_sep declaration (tag "@;")) p
+    fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)
 end
 
 module Rename = struct

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 "@[<v>%a@]" (list_sep declaration (tag "@;")) p
+    fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)
 
 end
 

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 *)

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 *)
 (*

src/ligo/ligo_parser/Markup.ml

@@ -1,3 +1,5 @@
+module Region = Tezos_utils.Region
+
 type lexeme = string
 
 type t =

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. *)

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"

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

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

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 ()) @@