integrate liquidity

src/ligo/ast_simplified.ml

@@ -52,17 +52,17 @@ and lambda = {
 and expression =
   (* Base *)
   | E_literal of literal
-  | E_constant of name * ae list (* For language constants, like (Cons hd tl) or (plus i j) *)
+  | E_constant of (name * ae list) (* For language constants, like (Cons hd tl) or (plus i j) *)
   | E_variable of name
   | E_lambda of lambda
-  | E_application of ae * ae
+  | E_application of (ae * ae)
   (* E_Tuple *)
   | E_tuple of ae list
   (* Sum *)
-  | E_constructor of name * ae (* For user defined constructors *)
+  | E_constructor of (name * ae) (* For user defined constructors *)
   (* E_record *)
   | E_record of ae_map
-  | E_accessor of ae * access_path
+  | E_accessor of (ae * access_path)
   (* Data Structures *)
   | E_map of (ae * ae) list
   | E_look_up of (ae * ae)

src/ligo/ast_typed.ml

@@ -57,18 +57,18 @@ and lambda = {
 and expression =
   (* Base *)
   | E_literal of literal
-  | E_constant of name * ae list (* For language constants, like (Cons hd tl) or (plus i j) *)
+  | E_constant of (name * ae list) (* For language constants, like (Cons hd tl) or (plus i j) *)
   | E_variable of name
-  | E_application of ae * ae
+  | E_application of (ae * ae)
   | E_lambda of lambda
   (* Tuple *)
   | E_tuple of ae list
-  | E_tuple_accessor of ae * int (* Access n'th tuple's element *)
+  | E_tuple_accessor of (ae * int) (* Access n'th tuple's element *)
   (* Sum *)
-  | E_constructor of name * ae (* For user defined constructors *)
+  | E_constructor of (name * ae) (* For user defined constructors *)
   (* Record *)
   | E_record of ae_map
-  | E_record_accessor of ae * string
+  | E_record_accessor of (ae * string)
   (* Data Structures *)
   | E_map of (ae * ae) list
   | E_look_up of (ae * ae)

src/ligo/multifix/generator.ml

@@ -20,7 +20,9 @@ module O = struct
     | Trail_force_ne of token
     | Lead of token
     | Lead_ne of token
-    | Separator of token
+    | Separated of token
+    | Separated_ne of token
+    | Separated_nene of token
     | Naked
     | Naked_ne
 
@@ -256,7 +258,10 @@ module Print_Grammar = struct
                  | Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ ","
                  | Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ ","
                  | Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ ","
-                 | Separator s -> "separated_list(" ^ (Token.to_string s) ^ ",")
+                 | Separated s -> "separated_list(" ^ (Token.to_string s) ^ ","
+                 | Separated_ne s -> "separated_list_ne(" ^ (Token.to_string s) ^ ","
+                 | Separated_nene s -> "separated_list_nene(" ^ (Token.to_string s) ^ ","
+                )
                 s
           | `Token t -> i := !i - 1 ; string ppf @@ Token.to_string t) ;
           i := !i + 1
@@ -302,7 +307,10 @@ module Print_Grammar = struct
             | Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ ","
             | Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ ","
             | Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ ","
-            | Separator s -> "separated_list(" ^ (Token.to_string s) ^ ",")
+            | Separated s -> "separated_list(" ^ (Token.to_string s) ^ ","
+            | Separated_ne s -> "separated_list_ne(" ^ (Token.to_string s) ^ ","
+            | Separated_nene s -> "separated_list_nene(" ^ (Token.to_string s) ^ ","
+           )
            (match content with | `Lower -> prev_lvl_name | `Named s -> s | `Current -> cur_lvl_name)
        | `Named n ->
            fprintf ppf "%s = wrap(%s)" letters.(!i) n
@@ -376,13 +384,13 @@ end
 let infix : string -> [`Left | `Right] -> token -> O.n_operator = fun name assoc t ->
   match assoc with
   | `Left -> make_name name [`Current ; `Token t ; `Lower]
-  | `Right -> make_name name [`Current ; `Token t ; `Lower]
+  | `Right -> make_name name [`Lower ; `Token t ; `Current]
 
 (* Ocaml is bad *)
 let empty_infix : string -> [`Left | `Right] -> O.n_operator = fun name assoc ->
   match assoc with
   | `Left -> make_name name [`Current ; `Lower]
-  | `Right -> make_name name [`Current ; `Lower]
+  | `Right -> make_name name [`Lower ; `Current]
 
 
 let paren : string -> string -> O.n_operator = fun constructor_name name ->
@@ -469,7 +477,7 @@ module Expression = struct
   let application = empty_infix "application" `Right
 
   let type_annotation = make_name "type_annotation" [
-      `Current ; `Token COLON ; `Named type_expression_name
+      `Current ; `Token COLON ; `Named restricted_type_expression_name
     ]
 
   let list : O.n_operator = make_name "list" [
@@ -517,7 +525,10 @@ module Expression = struct
       `Lower ;
     ]
 
-  let sequence = infix "sequence" `Left SEMICOLON
+  (* let sequence = infix "sequence" `Left SEMICOLON *)
+  let sequence = make_name "sequence" [
+      `List (Separated_nene SEMICOLON , `Lower)
+    ]
 
   let match_clause = make_name "e_match_clause" [
       make_name "" [`Named pattern_name ; `Token ARROW ; `Named no_match_name]
@@ -556,14 +567,18 @@ module Expression = struct
 
   let assignment : O.n_operator = infix "assign" `Left LEFT_ARROW
 
-  let pair = infix "pair" `Left COMMA
+  let tuple = make_name "tuple" [
+      `List (Separated_nene COMMA, `Lower)
+    ]
 
   let name = make_name "name" [`Token TILDE ; `Current]
 
-  let main_hierarchy = [
+  let main_hierarchy_name = "expression_main"
-      [pair] ;
+
-      [application] ;
+  let main_hierarchy = O.name_hierarchy main_hierarchy_name "Eh" [
+      [tuple] ;
       [type_annotation] ;
+      [application] ;
       [lt ; le ; gt ; eq] ;
       [assignment] ;
       [cons] ;
@@ -573,23 +588,23 @@ module Expression = struct
       [name] ;
       [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ;
       [paren "bottom" expression_name] ;
-  ]
+  ] []
 
-  let no_sequence_expression = O.name_hierarchy no_seq_name "Es" (
+  let no_sequence_expression = O.name_hierarchy no_seq_name "Es" [
-      [let_in ; fun_ ; record ; ite ; it ; match_with] ::
+      [let_in ; fun_ ; record ; ite ; it ; match_with] ;
-      main_hierarchy
+      [make_name "main" [`Named main_hierarchy_name]] ;
-    ) []
+    ] []
 
-  let no_match_expression = O.name_hierarchy no_match_name "Em" (
+  let no_match_expression = O.name_hierarchy no_match_name "Em" [
-      [let_in ; fun_ ; record ; ite ; it ] ::
+      [let_in ; fun_ ; record ; ite ; it ] ;
-      main_hierarchy
+      [make_name "main" [`Named main_hierarchy_name]] ;
-    ) []
+    ] []
 
-  let expression = O.name_hierarchy expression_name "E" (
+  let expression = O.name_hierarchy expression_name "E" [
-      [sequence] ::
+      [sequence] ;
-      [let_in ; fun_ ; record ; ite ; it ; match_with] ::
+      [let_in ; fun_ ; record ; ite ; it ; match_with] ;
-      main_hierarchy
+      [make_name "main" [`Named main_hierarchy_name]] ;
-    ) []
+    ] []
 
   let singletons = List.map O.rule_singleton [record_element ; match_clause]
 end
@@ -599,16 +614,6 @@ module Type_expression = struct
   open Token
   open O
 
-  let list : O.n_operator = make_name "list" [
-      `Token LIST ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ;
-    ]
-
-  let let_in : O.n_operator = make_name "let_in" [
-      `Token LET ; `Named variable_name ;
-      `Token EQUAL ; `Current ;
-      `Token IN ; `Current ;
-    ]
-
   let record_element : O.rule = make_name "t_record_element" [
       make_name "" [`Named variable_name ; `Token COLON ; `Named type_expression_name]
     ]
@@ -621,7 +626,13 @@ module Type_expression = struct
 
   let application = empty_infix "application" `Left
 
-  let pair = infix "pair" `Left COMMA
+  (* let pair = infix "pair" `Left COMMA *)
+  let tuple = make_name "tuple" [
+      `List (Separated_nene COMMA, `Lower)
+    ]
+  (* let pair = make_name "tuple" [
+   *     `List (Separated COMMA, `Lower)
+   *   ] *)
 
   let type_variable : O.n_operator = make_name "variable" [ `Named variable_name ]
 
@@ -631,10 +642,9 @@ module Type_expression = struct
     ] []
 
   let type_expression = O.name_hierarchy type_expression_name "T" [
-      [let_in ; record ] ;
+      [record] ;
-      [pair] ;
+      [tuple] ;
       [application] ;
-      [list] ;
       [type_variable] ;
       [paren "paren" type_expression_name]
     ] []
@@ -681,6 +691,7 @@ let language = O.language program_name (
   ) [
     Pattern.main ;
     Pattern.restricted_pattern ;
+    Expression.main_hierarchy ;
     Expression.no_sequence_expression ;
     Expression.no_match_expression ;
     Expression.expression ;

src/ligo/multifix/pre_parser.mly

@@ -59,5 +59,14 @@ lead_list_content(separator, X):
 lead_list_first (separator, X):
   | option(separator) x = X { [ x ] }
 
+separated_list_ne(separator, X):
+  | x = X { [x] }
+  | x = X separator xs = separated_list_ne(separator, X) { x :: xs }
+
+separated_list_nene(separator, X):
+  | x = X separator y = X { [x ; y] }
+  | x = X separator xs = separated_list_nene(separator, X) { x :: xs }
+
+
 %inline wrap(X):
   | x = X { let loc = Location.make $startpos $endpos in Location.wrap ~loc x }

src/ligo/simplify_multifix.ml

@@ -3,20 +3,43 @@ open Function
 module I = Multifix.Ast
 module O = Ast_simplified
 
-let unwrap = Location.unwrap
+let unwrap : type a . a Location.wrap -> a = Location.unwrap
-
-let expression : I.expression -> O.expression result = fun _ ->
-  simple_fail ""
 
 let type_variable : string -> O.type_expression result = fun str ->
   ok @@ O.T_variable str
 
-let type_expression : I.type_expression -> O.type_expression result = fun te ->
+let rec type_expression : I.type_expression -> O.type_expression result = fun te ->
   match te with
   | T_variable tv ->
       let%bind tv' = bind_map_location type_variable tv in
       ok @@ unwrap tv'
-  | _ -> simple_fail "lel"
+  | T_tuple lst ->
+      let%bind lst' = bind_map_list (bind_map_location type_expression) lst in
+      ok @@ O.T_tuple (List.map unwrap lst')
+  | T_paren p ->
+      let%bind p' = bind_map_location type_expression p in
+      ok @@ unwrap p'
+  | T_record r ->
+      let aux : I.t_record_element -> _ = fun (T_record_element (s, te)) ->
+        let%bind te' = bind_map_location type_expression te in
+        ok (s, te')
+      in
+      let%bind r' = bind_map_list (bind_map_location aux) r in
+      let te_map =
+        let lst = List.map ((fun (x, y) -> unwrap x, unwrap y) >| unwrap) r' in
+        let open Map.String in
+        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)
 
 let restricted_type_expression : I.restricted_type_expression -> O.type_expression result = fun rte ->
   match rte with
@@ -25,6 +48,101 @@ let restricted_type_expression : I.restricted_type_expression -> O.type_expressi
       ok @@ unwrap tv'
   | Tr_paren te -> type_expression (unwrap te)
 
+let rec expression : I.expression -> O.annotated_expression result = fun e ->
+  match e with
+  | E_sequence _
+  | E_let_in _
+  | E_ifthen _
+  | E_ifthenelse _
+    -> simple_fail "not block expressions in local expressions yet"
+  | E_fun _ -> simple_fail "no local functions yet"
+  | E_match _ -> simple_fail "no match in expressions yet"
+  | E_main m ->
+      let%bind m' = bind_map_location expression_main m in
+      ok @@ unwrap m'
+  | E_record r ->
+      let aux : I.e_record_element -> _ = fun re ->
+        match re with
+        | E_record_element_record_implicit _ -> simple_fail "no implicit record element yet"
+        | E_record_element_record_explicit (s, e) ->
+            let%bind e' = bind_map_location expression_no_seq e in
+            ok (s, e')
+      in
+      let%bind r' = bind_map_list (bind_map_location aux) r in
+      let e_map =
+        let lst = List.map ((fun (x, y) -> unwrap x, unwrap y) >| unwrap) r' in
+        let open Map.String in
+        List.fold_left (fun prec (k , v) -> add k v prec) empty lst
+      in
+      ok @@ O.(ae @@ E_record e_map)
+
+and expression_main : I.expression_main -> O.annotated_expression result = fun em ->
+  let return x = ok O.(ae x) in
+  let simple_binop name ab =
+    let%bind (a' , b') = bind_map_pair (bind_map_location expression_main) ab in
+    return @@ E_constant (name, [unwrap a' ; unwrap b']) in
+  match em with
+  | Eh_tuple lst ->
+      let%bind lst' = bind_map_list (bind_map_location expression_main) lst in
+      return @@ E_tuple (List.map unwrap lst')
+  | Eh_application farg ->
+      (* TODO: constructor case *)
+      let%bind farg' = bind_map_pair (bind_map_location expression_main) farg in
+      return @@ E_application (Tuple.map2 unwrap farg')
+  | Eh_type_annotation (e, te) ->
+      let%bind e' = bind_map_location expression_main e in
+      let%bind e'' = match (unwrap e').type_annotation with
+        | None -> ok (unwrap e').expression
+        | Some _ -> simple_fail "can't double annotate" in
+      let%bind te' = bind_map_location restricted_type_expression te in
+      ok @@ O.annotated_expression e'' (Some (unwrap te'))
+  | Eh_lt ab ->
+      simple_binop "LT" ab
+  | Eh_gt ab ->
+      simple_binop "GT" ab
+  | Eh_le ab ->
+      simple_binop "LE" ab
+  | Eh_eq ab ->
+      simple_binop "EQ" ab
+  | Eh_cons ab ->
+      simple_binop "CONS" ab
+  | Eh_addition ab ->
+      simple_binop "ADD" ab
+  | Eh_substraction ab ->
+      simple_binop "MINUS" ab
+  | Eh_multiplication ab ->
+      simple_binop "TIMES" ab
+  | Eh_division ab ->
+      simple_binop "DIV" ab
+  | Eh_int n ->
+      return @@ E_literal (Literal_int (unwrap n))
+  | Eh_string s ->
+      return @@ E_literal (Literal_string (unwrap s))
+  | Eh_unit _ ->
+      return @@ E_literal Literal_unit
+  | Eh_tz _ ->
+      simple_fail "tz literals not supported yet"
+  | Eh_module_ident _ ->
+      simple_fail "modules not supported yet"
+  | Eh_variable v ->
+      return @@ E_variable (unwrap v)
+  | Eh_constructor _ ->
+      simple_fail "constructor without parameter"
+  | Eh_list _ ->
+      simple_fail "list not supported yet"
+  | Eh_name _ ->
+      simple_fail "named parameter not supported yet"
+  | Eh_assign _ ->
+      simple_fail "assign not supported yet"
+  | Eh_accessor _ ->
+      simple_fail "accessor not supported yet"
+  | Eh_bottom e ->
+      expression (unwrap e)
+
+and expression_no_seq : I.expression_no_seq -> O.annotated_expression result = fun mns ->
+  match mns with
+  | _ -> simple_fail "todo"
+
 let statement : I.statement -> O.declaration result = fun s ->
   match s with
   | Statement_variable_declaration ([n], e) ->
@@ -51,7 +169,10 @@ let statement : I.statement -> O.declaration result = fun s ->
       let name' = unwrap name in
       let%bind e' = bind_map_location expression e in
       let%bind ty' = bind_map_location restricted_type_expression ty in
-      let ae = O.annotated_expression (unwrap e') (Some (unwrap ty')) in
+      let%bind e'' = match (unwrap e').type_annotation with
+        | None -> ok (unwrap e').expression
+        | Some _ -> simple_fail "can't add an annotation at the expression of a declaration" in
+      let ae = O.annotated_expression e'' (Some (unwrap ty')) in
       ok @@ O.Declaration_constant {name = name' ; annotated_expression = ae}
   | Statement_variable_declaration _ -> simple_fail "no sugar-candy for fun declarations yet"
   | Statement_init_declaration _ -> simple_fail "no init declaration yet"