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

src/ligo/ast_simplified/combinators.ml

@@ -1,4 +1,5 @@
 open Types
+open Trace
 
 module SMap = Map.String
 
@@ -6,6 +7,16 @@ let get_name : named_expression -> string = fun x -> x.name
 let get_type_name : named_type_expression -> string = fun x -> x.type_name
 let get_type_annotation (x:annotated_expression) = x.type_annotation
 
+let i_assignment : _ -> instruction = fun x -> I_assignment x
+let named_expression name annotated_expression = { name ; annotated_expression }
+let named_typed_expression name expression ty = { name ; annotated_expression = { expression ; type_annotation = Some ty } }
+
+let get_untyped_expression : annotated_expression -> expression result = fun ae ->
+  let%bind () =
+    trace_strong (simple_error "expression is typed") @@
+    Assert.assert_none ae.type_annotation in
+  ok ae.expression
+
 let t_bool      : type_expression = T_constant ("bool", [])
 let t_string    : type_expression = T_constant ("string", [])
 let t_bytes     : type_expression = T_constant ("bytes", [])

src/ligo/contracts/variant-matching.ligo

@@ -1,9 +1,11 @@
 type foobar is
 | Foo of int
 | Bar of bool
+| Kee of nat
 
 function fb(const p : foobar) : int is
   block { skip } with (case p of
   | Foo (n) -> n
   | Bar (t) -> 42
+  | Kee (n) -> 23
   end)

src/ligo/contracts/variant.ligo

@@ -1,8 +1,10 @@
 type foobar is
 | Foo of int
 | Bar of bool
+| Kee of nat
 
 const foo : foobar = Foo (42)
 
 const bar : foobar = Bar (True)
 
+const kee : foobar = Kee (23n)

src/ligo/operators/operators.ml

@@ -13,6 +13,7 @@ module Simplify = struct
     ("option" , 1) ;
     ("set" , 1) ;
     ("map" , 2) ;
+    ("big_map" , 2) ;
   ]
 
   let constants = [

src/ligo/parser/camligo/generator.ml

@@ -210,7 +210,7 @@ module Print_AST = struct
     let levels = List.Ne.map get_content ((get_content nh).levels) in
     let nops = List.Ne.concat levels in
     let name = get_name nh in
-    fprintf ppf "%s %s = @.@[%a@]" t
+    fprintf ppf "%s %s =@.@[%a@]" t
       name
       (list_sep (n_operator nh.content.prefix name) new_line) nops
 

src/ligo/simplify/camligo.ml

@@ -14,6 +14,46 @@ let type_variable : string -> O.type_expression result = fun str ->
   | Some _ -> simple_fail "non-nullary type constructor"
   | None -> ok @@ O.T_variable str
 
+let get_param_restricted_pattern : I.param -> I.restricted_pattern Location.wrap result = fun p ->
+  match p with
+  | I.Param_restricted_pattern c -> ok c
+  | _ -> simple_fail "not a restricted param pattern"
+
+let get_unrestricted_pattern : I.restricted_pattern -> I.pattern Location.wrap result = fun rp ->
+  match rp with
+  | I.Pr_restrict p -> ok p
+  | _ -> simple_fail "not an unrestricted pattern"
+
+let get_p_type_annotation : I.pattern -> (I.pattern Location.wrap * I.restricted_type_expression Location.wrap) result = fun p ->
+  match p with
+  | I.P_type_annotation pta -> ok pta
+  | _ -> simple_fail "not a pattern type annotation"
+
+let get_p_variable : I.pattern -> string Location.wrap result = fun p ->
+  match p with
+  | I.P_variable v -> ok v
+  | _ -> simple_fail "not a pattern variable"
+
+let get_p_typed_variable : I.pattern -> (string Location.wrap * I.restricted_type_expression Location.wrap) result = fun p ->
+  let%bind (p' , rte) = get_p_type_annotation p in
+  let%bind var = get_p_variable (unwrap p') in
+  ok (var , rte)
+
+let get_arg : I.param -> _ result = fun arg ->
+  let%bind rp =
+    get_param_restricted_pattern arg >>?
+    Function.compose get_unrestricted_pattern unwrap in
+  let%bind (var , rte) = get_p_typed_variable (unwrap rp) in
+  ok (var , rte)
+
+let get_type_annotation_ : I.type_annotation_ -> I.type_expression Location.wrap result = fun p ->
+    match p with
+    | I.Type_annotation_ p -> ok p
+
+let get_e_match_clause : I.e_match_clause -> (I.pattern Location.wrap * I.expression_no_match Location.wrap) result = fun e ->
+  match e with
+  | E_match_clause c -> ok c
+
 let rec type_expression : I.type_expression -> O.type_expression result = fun te ->
   match te with
   | T_variable tv ->
@@ -37,15 +77,31 @@ let rec type_expression : I.type_expression -> O.type_expression result = fun te
         List.fold_left (fun prec (k , v) -> add k v prec) empty lst
       in
       ok @@ O.T_record te_map
-  | T_application (f, arg) ->
-      let%bind (f', arg') = bind_map_pair (bind_map_location type_expression) (f, arg) in
-      let%bind name = match unwrap f' with
-        | O.T_variable v -> ok v
-        | _ -> simple_fail "can't apply to non-vars" in
-      let args = match unwrap arg' with
-        | T_tuple lst -> lst
-        | x -> [ x ] in
-      ok @@ O.T_constant (name, args)
+  | T_application (arg , f) ->
+      let%bind arg' = bind_map_location type_expression arg in
+      match unwrap f with
+        | I.T_variable v -> (
+            match List.assoc_opt v.wrap_content type_constants with
+            | Some n -> (
+                match arg'.wrap_content with
+                | T_tuple lst -> (
+                    let%bind () =
+                      trace (simple_error "bad arity") @@
+                      Assert.assert_list_size lst n in
+                    ok @@ O.T_constant (v.wrap_content , lst)
+                  )
+                | _ -> simple_fail "bad arity"
+              )
+            | None -> (
+                let error =
+                  let title () = "unrecognized type-constant" in
+                  let content () = Format.asprintf "%s" v.wrap_content in
+                  error title content
+                in
+                fail error
+              )
+          )
+        | _ -> simple_fail "type applying to non-var"
 
 let restricted_type_expression : I.restricted_type_expression -> O.type_expression result = fun rte ->
   match rte with
@@ -68,6 +124,71 @@ let rec expression : I.expression -> O.annotated_expression result = fun e ->
       ok @@ unwrap m'
   | E_record r -> expression_record r
 
+and expression_no_match_block : I.expression_no_match -> O.block result = fun e ->
+  match e with
+  | I.Em_let_in _|I.Em_fun _|I.Em_record _|I.Em_ifthenelse _|I.Em_ifthen _
+  |I.Em_main _ -> simple_fail "lel"
+
+and sequence_block : I.expression Location.wrap list -> O.block result = fun s ->
+  let%bind blocks = bind_map_list (bind_map_location expression_block) s in
+  let block = List.(concat @@ map unwrap blocks) in
+  ok block
+
+and let_in_block : (I.pattern Location.wrap * I.expression Location.wrap * I.expression Location.wrap) -> O.block result =
+  fun (var , expr , body) ->
+  let%bind (var' , te) = get_p_typed_variable (unwrap var) in
+  let%bind expr' =
+    let%bind expr' = bind_map_location expression expr in
+    bind_map_location O.Combinators.get_untyped_expression expr' in
+  let%bind te' = bind_map_location restricted_type_expression te in
+  let instruction = O.Combinators.(i_assignment @@ named_typed_expression (unwrap var') (unwrap expr') (unwrap te')) in
+  let%bind body' = bind_map_location expression_block body in
+  ok @@ instruction :: (unwrap body')
+
+and if_then_else_block : (I.expression Location.wrap * I.expression Location.wrap * I.expression Location.wrap) -> O.block result =
+  fun (cond , branch_true , branch_false) ->
+  let%bind cond' = bind_map_location expression cond in
+  let%bind branch_true' = bind_map_location expression_block branch_true in
+  let%bind branch_false' = bind_map_location expression_block branch_false in
+  ok [ O.I_matching ((unwrap cond') , Match_bool { match_true = (unwrap branch_true') ; match_false = (unwrap branch_false') }) ]
+
+and if_then_block : (I.expression Location.wrap * I.expression Location.wrap) -> O.block result =
+  fun (cond , branch_true) ->
+  let%bind cond' = bind_map_location expression cond in
+  let%bind branch_true' = bind_map_location expression_block branch_true in
+  let branch_false = O.I_skip in
+  ok [ O.I_matching ((unwrap cond') , Match_bool { match_true = (unwrap branch_true') ; match_false = [ branch_false ] }) ]
+
+and match_clauses : type a . (I.pattern * a) list -> a O.matching result = fun _clauses ->
+  let match_bool _ = simple_fail "" in
+  let match_stuff _ = simple_fail "" in
+  bind_find_map_list (simple_error "no weird matching yet") (fun f -> f ()) [ match_bool ; match_stuff ]
+
+and match_block : _ -> O.block result = fun (case , clauses) ->
+  let%bind case' = bind_map_location expression case in
+  let%bind clauses' =
+    let u = List.map unwrap clauses in
+    let%bind cs = bind_map_list get_e_match_clause u in
+    let ucs = List.map (Tuple.map_h_2 unwrap unwrap) cs in
+    let%bind ucs' =
+      let aux (x , y) =
+        let%bind y' = expression_no_match_block y in
+        ok (x , y') in
+      bind_map_list aux ucs in
+    ok ucs' in
+  let%bind matching = match_clauses clauses' in
+  ok [ O.I_matching ((unwrap case') , matching) ]
+
+and expression_block : I.expression -> O.block result = fun e ->
+  match e with
+  | I.E_sequence s -> sequence_block s
+  | I.E_let_in li -> let_in_block li
+  | I.E_ifthenelse ite -> if_then_else_block ite
+  | I.E_ifthen it -> if_then_block it
+  | I.E_match cc -> match_block cc
+  |I.E_fun _|I.E_record _
+  |I.E_main _ -> simple_fail "no regular expression in blocks"
+
 and expression_record : _ -> O.annotated_expression result = fun r ->
   let aux : I.e_record_element -> _ = fun re ->
     match re with
@@ -163,19 +284,24 @@ let let_content : I.let_content -> _ result = fun (Let_content (n, args, ty_opt,
   let%bind () =
     trace_strong (simple_error "no sugar-candy for args yet") @@
     Assert.assert_list_empty args in
-  let%bind ty =
-    trace_option (simple_error "top-level declarations need a type") @@
-    ty_opt in
-  let%bind e' = bind_map_location expression e in
-  let%bind () =
-    trace_strong (simple_error "no annotation for a top-level expression") @@
-    Assert.assert_none (unwrap e').type_annotation in
-  let e'' = (unwrap e').expression in
+  let%bind args' = bind_map_list (bind_map_location get_arg) args in
   let%bind ty' =
-    let (I.Type_annotation_ ty') = unwrap ty in
-    bind_map_location type_expression ty' in
-  let ae = make_e_a_full e'' (unwrap ty') in
-  ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = ae}
+    let%bind tya =
+      trace_option (simple_error "top-level declarations need a type") @@
+      ty_opt in
+    let%bind ty = get_type_annotation_ (unwrap tya) in
+    bind_map_location type_expression ty in
+  match args' with
+  | [] -> ( (* No arguments. Simplify as regular value. *)
+      let%bind e' =
+        let%bind e' = bind_map_location expression e in
+        bind_map_location O.Combinators.get_untyped_expression e' in
+      let ae = make_e_a_full (unwrap e') (unwrap ty') in
+      ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = ae}
+    )
+  | _lst -> ( (* Arguments without fun. *)
+      simple_fail "no syntactic sugar for functions yet"
+    )
 
 let statement : I.statement -> O.declaration result = fun s ->
   match s with

src/ligo/test/integration_tests.ml

@@ -22,6 +22,9 @@ let variant () : unit result =
   let%bind () =
     let expected = e_a_constructor "Bar" (e_a_bool true) in
     expect_evaluate program "bar" expected in
+  let%bind () =
+    let expected = e_a_constructor "Kee" (e_a_nat 23) in
+    expect_evaluate program "kee" expected in
   ok ()
 
 let variant_matching () : unit result =
@@ -29,7 +32,10 @@ let variant_matching () : unit result =
   let%bind () =
     let make_input = fun n -> e_a_constructor "Foo" (e_a_int n) in
     let make_expected = e_a_int in
-    expect_n program "fb" make_input make_expected
+    expect_n program "fb" make_input make_expected >>? fun () ->
+    expect program "fb" (e_a_constructor "Kee" (e_a_nat 50)) (e_a_int 23) >>? fun () ->
+    expect program "fb" (e_a_constructor "Bar" (e_a_bool true)) (e_a_int 42) >>? fun () ->
+    ok ()
   in
   ok ()
 

src/ligo/test/multifix_tests.ml

@@ -7,7 +7,7 @@ let basic () : unit result =
   ok ()
 
 let simplify () : unit result =
-  let%bind raw = User.parse_file "./contracts/basic.mligo" in
+  let%bind raw = User.parse_file "./contracts/new-syntax.mligo" in
   let%bind _simpl = Simplify.Camligo.main raw in
   ok ()