diff --git a/src/ligo/ast_simplified.ml b/src/ligo/ast_simplified.ml index 81cb73401..7873ab08a 100644 --- a/src/ligo/ast_simplified.ml +++ b/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) diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index 963635cd8..9493f9392 100644 --- a/src/ligo/ast_typed.ml +++ b/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) diff --git a/src/ligo/multifix/generator.ml b/src/ligo/multifix/generator.ml index 564c47384..4d61dcc00 100644 --- a/src/ligo/multifix/generator.ml +++ b/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 = [ - [pair] ; - [application] ; + let main_hierarchy_name = "expression_main" + + 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_in ; fun_ ; record ; ite ; it ; match_with] :: - main_hierarchy - ) [] + let no_sequence_expression = O.name_hierarchy no_seq_name "Es" [ + [let_in ; fun_ ; record ; ite ; it ; match_with] ; + [make_name "main" [`Named main_hierarchy_name]] ; + ] [] - let no_match_expression = O.name_hierarchy no_match_name "Em" ( - [let_in ; fun_ ; record ; ite ; it ] :: - main_hierarchy - ) [] + let no_match_expression = O.name_hierarchy no_match_name "Em" [ + [let_in ; fun_ ; record ; ite ; it ] ; + [make_name "main" [`Named main_hierarchy_name]] ; + ] [] - let expression = O.name_hierarchy expression_name "E" ( - [sequence] :: - [let_in ; fun_ ; record ; ite ; it ; match_with] :: - main_hierarchy - ) [] + let expression = O.name_hierarchy expression_name "E" [ + [sequence] ; + [let_in ; fun_ ; record ; ite ; it ; match_with] ; + [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 ] ; - [pair] ; + [record] ; + [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 ; diff --git a/src/ligo/multifix/pre_parser.mly b/src/ligo/multifix/pre_parser.mly index 702e8105c..159e13d5f 100644 --- a/src/ligo/multifix/pre_parser.mly +++ b/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 } diff --git a/src/ligo/simplify_multifix.ml b/src/ligo/simplify_multifix.ml index f1b09b248..bce76d617 100644 --- a/src/ligo/simplify_multifix.ml +++ b/src/ligo/simplify_multifix.ml @@ -3,20 +3,43 @@ open Function module I = Multifix.Ast module O = Ast_simplified -let unwrap = Location.unwrap - -let expression : I.expression -> O.expression result = fun _ -> - simple_fail "" +let unwrap : type a . a Location.wrap -> a = Location.unwrap 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"