Merge branch 'feature/LIGO-GITLAB-ISSUE-23-HIGHER-ORDER' into 'dev'

Issue 23 : Higher-order functions with more than one argument give weird errors

See merge request ligolang/ligo!103

src/passes/6-transpiler/dune

@@ -6,6 +6,7 @@
     tezos-utils
     ast_typed
     mini_c
+    self_mini_c
     operators
   )
   (preprocess

src/passes/6-transpiler/transpiler.ml

@@ -224,12 +224,20 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
 
 and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele ->
   match (AST.get_type' ele.type_value , ele.definition) with
-  | (AST.T_function (f , arg) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) ->
+  | (AST.T_function (arg , ret) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) ->
-    let%bind f' = transpile_type f in
+  begin
+    match ae.expression with
+    | E_lambda _ ->
+      let%bind ret' = transpile_type ret in
       let%bind arg' = transpile_type arg in
       let%bind env' = transpile_environment ae.environment in
       let sub_env = Mini_c.Environment.select captured_variables env' in
-    ok @@ Combinators.t_deep_closure sub_env f' arg'
+      if sub_env = [] then
+        transpile_type ele.type_value
+      else
+        ok @@ Combinators.t_deep_closure sub_env arg' ret'
+    | _ -> transpile_type ele.type_value
+  end
   | _ -> transpile_type ele.type_value
 
 and transpile_small_environment : AST.small_environment -> Environment.t result = fun x ->
@@ -275,7 +283,21 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
   | E_application (a, b) ->
       let%bind a = transpile_annotated_expression a in
       let%bind b = transpile_annotated_expression b in
-      return @@ E_application (a, b)
+      let%bind contains_closure =
+        Self_mini_c.Helpers.fold_type_value
+          (fun contains_closure exp ->
+            ok (contains_closure
+                || match exp with
+                   | T_deep_closure _ -> true
+                   | _ -> false))
+          false
+          b.type_value in
+      if contains_closure
+      then
+        let errmsg = Format.asprintf "Cannot apply closure in function arguments: %a\n"
+                       Mini_c.PP.expression_with_type b in
+        fail @@ simple_error errmsg
+      else return @@ E_application (a, b)
   | E_constructor (m, param) -> (
       let%bind param' = transpile_annotated_expression param in
       let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in

src/passes/7-self_mini_c/dune

@@ -0,0 +1,11 @@
+(library
+  (name self_mini_c)
+  (public_name ligo.self_mini_c)
+  (libraries
+    mini_c
+  )
+  (preprocess
+    (pps ppx_let)
+  )
+  (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
+)

src/passes/7-self_mini_c/helpers.ml

@@ -0,0 +1,160 @@
+open Mini_c
+open Trace
+
+let rec fold_type_value : ('a -> type_value -> 'a result) -> 'a -> type_value -> 'a result = fun f init t ->
+  let self = fold_type_value f in
+  let%bind init' = f init t in
+  match t with
+  | T_pair ((_, a), (_, b))
+  | T_or ((_, a), (_, b))
+  | T_function (a, b)
+  | T_map (a, b)
+  | T_big_map (a, b) ->
+     bind_fold_pair self init' (a, b)
+  | T_deep_closure (env, a, b) ->
+     bind_fold_list self init' (List.map snd env @ [a; b])
+  | T_list a
+  | T_set a
+  | T_contract a
+  | T_option a ->
+     self init' a
+  | T_base _ ->
+     ok init'
+
+type 'a folder = 'a -> expression -> 'a result
+let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
+  let self = fold_expression f in 
+  let%bind init' = f init e in
+  match e.content with
+  | E_variable _ | E_skip | E_make_none _
+  | E_make_empty_map (_,_) | E_make_empty_list _ 
+  | E_make_empty_set _ -> (
+    ok init'
+  )
+  | E_literal v -> (
+    match v with
+    | D_function an -> self init' an.body
+    | _ -> ok init'
+  )
+  | E_constant (_, lst) -> (
+      let%bind res = bind_fold_list self init' lst in
+      ok res
+  )
+  | E_closure af -> (
+      let%bind res = self init' af.body in
+      ok res
+  )
+  | E_application farg -> (
+      let%bind res = bind_fold_pair self init' farg in 
+      ok res
+  )
+  | E_iterator (_, ((_ , _) , body) , exp) -> (
+      let%bind res = bind_fold_pair self init' (exp,body) in
+      ok res
+  )
+  | E_fold (((_ , _) , body) , col , init) -> (
+      let%bind res = bind_fold_triple self init' (body,col,init) in
+      ok res
+  )
+  | E_while eb -> (
+      let%bind res = bind_fold_pair self init' eb in
+      ok res
+  ) 
+  | E_if_bool cab -> (
+      let%bind res = bind_fold_triple self init' cab in
+      ok res
+  )
+  | E_if_none (c, n, ((_, _) , s)) -> (
+      let%bind res = bind_fold_triple self init' (c,n,s) in
+      ok res
+  )
+  | E_if_cons (c, n, (((_, _) , (_, _)) , cons)) -> (
+      let%bind res = bind_fold_triple self init' (c,n,cons) in
+      ok res
+  )
+  | E_if_left (c, ((_, _) , l), ((_, _) , r)) -> (
+      let%bind res = bind_fold_triple self init' (c,l,r) in
+      ok res
+  )
+  | E_let_in ((_, _) , expr , body) -> (
+      let%bind res = bind_fold_pair self init' (expr,body) in
+      ok res
+  )
+  | E_sequence ab -> (
+      let%bind res = bind_fold_pair self init' ab in
+      ok res
+  )
+  | E_assignment (_, _, exp) -> (
+      let%bind res = self init' exp in
+      ok res
+  )
+
+type mapper = expression -> expression result
+
+let rec map_expression : mapper -> expression -> expression result = fun f e ->
+  let self = map_expression f in
+  let%bind e' = f e in
+  let return content = ok { e' with content } in
+  match e'.content with
+  | E_variable _ | E_skip | E_make_none _
+  | E_make_empty_map (_,_) | E_make_empty_list _ | E_make_empty_set _ as em -> return em
+  | E_literal v -> (
+      let%bind v' = match v with
+      | D_function an ->
+        let%bind body = self an.body in
+        ok @@ D_function { an with body }
+      | _ -> ok v in
+      return @@ E_literal v'
+  )
+  | E_constant (name, lst) -> (
+      let%bind lst' = bind_map_list self lst in
+      return @@ E_constant (name,lst')
+  )
+  | E_closure af -> (
+      let%bind body = self af.body in
+      return @@ E_closure { af with body } 
+  )
+  | E_application farg -> (
+      let%bind farg' = bind_map_pair self farg in 
+      return @@ E_application farg'
+  )
+  | E_iterator (s, ((name , tv) , body) , exp) -> (
+      let%bind (exp',body') = bind_map_pair self (exp,body) in
+      return @@ E_iterator (s, ((name , tv) , body') , exp')
+  )
+  | E_fold (((name , tv) , body) , col , init) -> (
+      let%bind (body',col',init') = bind_map_triple self (body,col,init) in
+      return @@ E_fold (((name , tv) , body') , col', init')
+  )
+  | E_while eb -> (
+      let%bind eb' = bind_map_pair self eb in
+      return @@ E_while eb'
+  ) 
+  | E_if_bool cab -> (
+      let%bind cab' = bind_map_triple self cab in
+      return @@ E_if_bool cab'
+  )
+  | E_if_none (c, n, ((name, tv) , s)) -> (
+      let%bind (c',n',s') = bind_map_triple self (c,n,s) in
+      return @@ E_if_none (c', n', ((name, tv) , s'))
+  )
+  | E_if_cons (c, n, (((hd, hdtv) , (tl, tltv)) , cons)) -> (
+      let%bind (c',n',cons') = bind_map_triple self (c,n,cons) in
+      return @@ E_if_cons (c', n', (((hd, hdtv) , (tl, tltv)) , cons'))
+  )
+  | E_if_left (c, ((name_l, tvl) , l), ((name_r, tvr) , r)) -> (
+      let%bind (c',l',r') = bind_map_triple self (c,l,r) in
+      return @@ E_if_left (c', ((name_l, tvl) , l'), ((name_r, tvr) , r'))
+  )
+  | E_let_in ((v , tv) , expr , body) -> (
+      let%bind (expr',body') = bind_map_pair self (expr,body) in
+      return @@ E_let_in ((v , tv) , expr' , body')
+  )
+  | E_sequence ab -> (
+      let%bind ab' = bind_map_pair self ab in
+      return @@ E_sequence ab'
+  )
+  | E_assignment (s, lrl, exp) -> (
+      let%bind exp' = self exp in
+      return @@ E_assignment (s, lrl, exp')
+  )

src/stages/mini_c/types.ml

@@ -64,7 +64,7 @@ and expression' =
   | E_closure of anon_function
   | E_skip
   | E_constant of string * expression list
-  | E_application of expression * expression
+  | E_application of (expression * expression)
   | E_variable of var_name
   | E_make_empty_map of (type_value * type_value)
   | E_make_empty_list of type_value
@@ -72,14 +72,14 @@ and expression' =
   | E_make_none of type_value
   | E_iterator of (string * ((var_name * type_value) * expression) * expression)
   | E_fold of (((var_name * type_value) * expression) * expression * expression)
-  | E_if_bool of expression * expression * expression
+  | E_if_bool of (expression * expression * expression)
   | E_if_none of expression * expression * ((var_name * type_value) * expression)
   | E_if_cons of (expression * expression * (((var_name * type_value) * (var_name * type_value)) * expression))
   | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression)
   | E_let_in of ((var_name * type_value) * expression * expression)
   | E_sequence of (expression * expression)
   | E_assignment of (string * [`Left | `Right] list * expression)
-  | E_while of expression * expression
+  | E_while of (expression * expression)
 
 and expression = {
   content : expression' ;

src/test/contracts/high-order.ligo

@@ -1,8 +1,37 @@
 // Test a PascaLIGO function which takes another PascaLIGO function as an argument
-
 function foobar (const i : int) : int is
   function foo (const i : int) : int is
     block { skip } with i ;
   function bar (const f : int -> int) : int is
     block { skip } with f ( i ) ;
   block { skip } with bar (foo) ;
+
+// higher order function with more than one argument
+function higher2(const i: int; const f: int -> int): int is
+    block { 
+        const ii: int = f(i)
+     } with ii
+
+function foobar2 (const i : int) : int is
+  function foo2 (const i : int) : int is
+    block { skip } with i;
+  block { skip } with higher2(i,foo2)
+
+// This is not supported yet:
+// const a : int = 123;
+// function foobar3 (const i : int) : int is
+//   function foo2 (const i : int) : int is
+//     block { skip } with (a+i);
+//   block { skip } with higher2(i,foo2)
+
+function f (const i : int) : int is
+  block { skip }
+  with i
+
+function g (const i : int) : int is
+  block { skip }
+  with f(i)
+
+function foobar4 (const i : int) : int is
+  block { skip }
+  with g(g(i))

src/test/integration_tests.ml

@@ -111,7 +111,12 @@ let shadow () : unit result =
 let higher_order () : unit result =
   let%bind program = type_file "./contracts/high-order.ligo" in
   let make_expect = fun n -> n in
-  expect_eq_n_int program "foobar" make_expect
+  let%bind _ = expect_eq_n_int program "foobar" make_expect in
+  let%bind _ = expect_eq_n_int program "foobar2" make_expect in
+  (* not supported yet:
+  let%bind _ = expect_eq_n_int program "foobar3" make_expect in *)
+  let%bind _ = expect_eq_n_int program "foobar4" make_expect in
+  ok () 
 
 let shared_function () : unit result =
   let%bind program = type_file "./contracts/function-shared.ligo" in

vendors/ligo-utils/simple-utils/trace.ml

@@ -592,6 +592,20 @@ let bind_fold_list f init lst =
   in
   List.fold_left aux (ok init) lst
 
+let bind_fold_pair f init (a,b) = 
+  let aux x y =
+    x >>? fun x ->
+    f x y
+  in
+  List.fold_left aux (ok init) [a;b]
+
+let bind_fold_triple f init (a,b,c) = 
+  let aux x y =
+    x >>? fun x ->
+    f x y
+  in
+  List.fold_left aux (ok init) [a;b;c]
+
 let bind_fold_map_list = fun f acc lst ->
   let rec aux (acc , prev) f = function
     | [] -> ok (acc , prev)
@@ -661,10 +675,17 @@ let bind_and (a, b) =
   a >>? fun a ->
   b >>? fun b ->
   ok (a, b)
+let bind_and3 (a, b, c) =
+  a >>? fun a ->
+  b >>? fun b ->
+  c >>? fun c ->
+  ok (a, b, c)
 
 let bind_pair = bind_and
 let bind_map_pair f (a, b) =
   bind_pair (f a, f b)
+let bind_map_triple f (a, b, c) =
+  bind_and3 (f a, f b, f c)
 
 
 (**