complete camligo simplify

src/ligo/contracts/new-syntax.mligo

@@ -1,6 +1,3 @@
-(* Smart contract for voting. Winners of vote split the contract
-   balance at the end of the voting period. *)
-
 (** Type of storage for this contract *)
 type storage = {
   challenge : string ;
@@ -20,4 +17,4 @@ let%entry attempt (p:param) storage =
   if Crypto.hash (Bytes.pack p.attempt) <> Bytes.pack storage.challenge then failwith "Failed challenge" ;
   let transfer : operation = Operation.transfer (sender , 10tz) in
   let storage : storage = storage.challenge <- p.new_challenge in
-  ([] , storage)
+  ((list [] : operation list), storage)

src/ligo/parser/camligo/generator.ml

@@ -424,8 +424,8 @@ module Pattern = struct
 
   let application = empty_infix "application" `Left
 
-  let list : O.n_operator = make_name "list" [
+  let data_structure : O.n_operator = make_name "data_structure" [
-      `Token LIST ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ;
+      `Named variable_name ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ;
     ]
 
   let record_element : O.rule = make_name "p_record_element" [
@@ -460,10 +460,11 @@ module Pattern = struct
     ] []
 
   let main = O.name_hierarchy pattern_name "P" [
-      [application ; record] ;
+      [record] ;
       [type_annotation] ;
       [pair] ;
-      [list] ;
+      [data_structure] ;
+      [application] ;
       [variable ; constructor ; module_ident ; unit] ;
       [paren "paren" pattern_name]
     ] []
@@ -482,8 +483,8 @@ module Expression = struct
       `Current ; `Token COLON ; `Named restricted_type_expression_name
     ]
 
-  let list : O.n_operator = make_name "list" [
+  let data_structure : O.n_operator = make_name "data_structure" [
-      `Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ;
+      `Named variable_name ; `Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ;
     ]
 
   let fun_ : O.n_operator = make_name "fun" [
@@ -584,10 +585,10 @@ module Expression = struct
       [lt ; le ; gt ; eq ; neq] ;
       [assignment] ;
       [cons] ;
-      [application] ;
       [addition ; substraction] ;
       [multiplication ; division] ;
-      [list] ;
+      [application] ;
+      [data_structure] ;
       [name] ;
       [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ;
       [paren "bottom" expression_name] ;
@@ -627,7 +628,7 @@ module Type_expression = struct
       `Token RBRACKET ;
     ]
 
-  let application = empty_infix "application" `Left
+  let application = empty_infix "application" `Right
 
   let tuple = make_name "tuple" [
       `List (Separated_nene COMMA, `Lower)
@@ -636,6 +637,7 @@ module Type_expression = struct
   let type_variable : O.n_operator = make_name "variable" [ `Named variable_name ]
 
   let restricted_type_expression = O.name_hierarchy restricted_type_expression_name "Tr" [
+      [application] ;
       [type_variable] ;
       [paren "paren" type_expression_name] ;
     ] []
@@ -671,7 +673,6 @@ module Program = struct
     ]
 
   let type_annotation_name = "type_annotation_"
-
   let type_annotation : O.rule = make_name type_annotation_name [
       make_name "" [ `Token COLON ; `Named type_expression_name ] ;
     ]
@@ -687,13 +688,6 @@ module Program = struct
       ] ;
     ]
 
-  (* let statement : O.rule = make_name statement_name [
-   *     make_name "variable_declaration" [`Token LET ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ;
-   *     make_name "init_declaration" [`Token LET_INIT ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ;
-   *     make_name "entry_declaration" [`Token LET_ENTRY ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ;
-   *     make_name "type_declaration" [`Token TYPE ; `Named variable_name ; `Token EQUAL ; `Named type_expression_name] ;
-   *   ] *)
-
   let statement : O.rule = make_name statement_name [
       make_name "variable_declaration" [`Token LET ; `Named let_content_name] ;
       make_name "init_declaration" [`Token LET_INIT ; `Named let_content_name] ;

src/ligo/parser/camligo/lex/generator.ml

@@ -125,7 +125,6 @@ let tokens = [
   keyword "if" ;
   keyword "then" ;
   keyword "else" ;
-  keyword "list" ;
   (* keyword "block" ;
    * keyword "for" ;
    * keyword "const" ; *)

src/ligo/simplify/camligo.ml

@@ -53,6 +53,11 @@ let get_p_typed_variable : I.pattern -> (string Location.wrap * I.restricted_typ
   let%bind var = get_p_variable (unwrap p') in
   ok (var , rte)
 
+let get_eh_accessor : _ -> _ result = fun x ->
+  match x with
+  | I.Eh_accessor x -> ok x
+  | _ -> simple_fail "not a simple eh_accessor"
+
 let get_typed_variable_param : I.param -> _ result = fun arg ->
   let%bind up =
     let%bind rp = get_param_restricted_pattern arg in
@@ -133,14 +138,18 @@ let rec type_expression : I.type_expression -> O.type_expression result = fun te
         | I.T_variable v -> (
             match List.assoc_opt v.wrap_content type_constants with
             | Some n -> (
+                let error expected got =
+                  let title () = "bad arity" in
+                  let content () = Format.asprintf "Expected: %d. Got: %d." expected got in
+                  error title content in
                 match arg'.wrap_content with
                 | T_tuple lst -> (
                     let%bind () =
-                      trace (simple_error "bad arity") @@
+                      trace (error n (List.length lst)) @@
                       Assert.assert_list_size lst n in
                     ok @@ O.T_constant (v.wrap_content , lst)
                   )
-                | _ -> simple_fail "bad arity"
+                | e -> ok @@ O.T_constant ((unwrap v) , [ e ])
               )
             | None -> (
                 let error =
@@ -153,12 +162,15 @@ let rec type_expression : I.type_expression -> O.type_expression result = fun te
           )
         | _ -> simple_fail "type applying to non-var"
 
-let restricted_type_expression : I.restricted_type_expression -> O.type_expression result = fun rte ->
+let rec of_restricted_type_expression : I.restricted_type_expression -> I.type_expression = fun rte ->
+  let self = of_restricted_type_expression in
   match rte with
-  | Tr_variable tv ->
+  | Tr_variable tv -> T_variable tv
-      let%bind tv' = bind_map_location type_variable tv in
+  | Tr_application (a , b) -> T_application (Location.map self a , Location.map self b)
-      ok @@ unwrap tv'
+  | Tr_paren te -> unwrap te
-  | Tr_paren te -> type_expression (unwrap te)
+
+let restricted_type_expression : I.restricted_type_expression -> O.type_expression result =
+  Function.compose type_expression of_restricted_type_expression
 
 type last_instruction_result = (O.block * O.annotated_expression)
 type lir = last_instruction_result
@@ -197,7 +209,7 @@ and let_in_last_instruction :
   = fun l ->
   let (pat , expr , body) = l in
   let%bind (var , ty) = get_p_typed_variable (unwrap pat) in
-  let%bind ty' = restricted_type_expression (unwrap ty) in
+  let%bind ty' = type_expression @@ of_restricted_type_expression (unwrap ty) in
   let%bind expr' = expression (unwrap expr) in
   let%bind uexpr' = get_untyped_expression expr' in
   let%bind (body' , last') = expression_last_instruction (unwrap body) in
@@ -328,12 +340,24 @@ and expression_main : I.expression_main Location.wrap -> O.annotated_expression
       return @@ E_variable (unwrap v)
   | Eh_constructor _ ->
       simple_fail "constructor without parameter"
-  | Eh_list _ ->
+  | Eh_data_structure (kind , content) -> (
-      simple_fail "list not supported yet"
+      match unwrap kind with
+      | "list" -> (
+          let%bind lst = bind_map_list expression_main content in
+          ok @@ untyped_expression @@ E_list lst
+        )
+      | kind' -> (
+          let error =
+            let title () = "data-structures not supported yet" in
+            let content () = Format.asprintf "%s" kind' in
+            error title content in
+          fail error
+        )
+    )
   | Eh_name _ ->
       simple_fail "named parameter not supported yet"
-  | Eh_assign _ ->
+  | Eh_assign x ->
-      simple_fail "assign not supported yet"
+      simple_binop "ASSIGN" x
   | Eh_accessor (src , path) ->
       ok @@ O.(untyped_expression @@ e_accessor_props (untyped_expression @@ e_variable (unwrap src)) (List.map unwrap path))
   | Eh_bottom e ->