Threaded the srcloc for top-level declarations until transpiler.ml

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/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 =
@@ -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

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 aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
-    let%bind (e', d') = type_declaration e d in
+    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 ()) @@