From c32ace3afc4a5f5823b32d58cf3388b728192dac Mon Sep 17 00:00:00 2001 From: Galfour Date: Tue, 28 May 2019 15:36:14 +0000 Subject: [PATCH] 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