From 1918bc00d14339d8ec1a93e63e53d78a66a90eb3 Mon Sep 17 00:00:00 2001 From: Galfour Date: Wed, 20 Mar 2019 14:53:34 +0000 Subject: [PATCH] tmp --- .gitignore | 1 + src/ligo/ast_simplified.ml | 85 ++++ src/ligo/ast_typed.ml | 137 ++++++ src/ligo/bin/cli.ml | 2 +- src/ligo/dune | 8 +- src/ligo/lexer.mll | 76 --- .../{helpers => ligo-helpers}/dictionary.ml | 0 .../{helpers => ligo-helpers}/dictionary.mli | 0 src/ligo/{helpers => ligo-helpers}/dune | 0 .../{helpers => ligo-helpers}/environment.ml | 0 .../ligo-helpers.opam | 0 .../{helpers => ligo-helpers}/location.ml | 0 src/ligo/{helpers => ligo-helpers}/option.ml | 0 src/ligo/{helpers => ligo-helpers}/trace.ml | 11 + src/ligo/{helpers => ligo-helpers}/tree.ml | 0 src/ligo/{helpers => ligo-helpers}/wrap.ml | 0 src/ligo/ligo-helpers/x_map.ml | 1 + .../{parser => ligo-parser}/.Lexer.ml.tag | 0 .../{parser => ligo-parser}/.LexerMain.tag | 0 .../{parser => ligo-parser}/.Parser.mly.tag | 0 .../{parser => ligo-parser}/.ParserMain.tag | 0 src/ligo/{parser => ligo-parser}/.links | 0 src/ligo/{parser => ligo-parser}/AST.ml | 0 src/ligo/{parser => ligo-parser}/AST.mli | 0 src/ligo/{parser => ligo-parser}/AST2.ml | 174 ++++--- src/ligo/{parser => ligo-parser}/Error.mli | 0 src/ligo/{parser => ligo-parser}/EvalOpt.ml | 0 src/ligo/{parser => ligo-parser}/EvalOpt.mli | 0 src/ligo/{parser => ligo-parser}/FQueue.ml | 0 src/ligo/{parser => ligo-parser}/FQueue.mli | 0 src/ligo/{parser => ligo-parser}/LexToken.mli | 0 src/ligo/{parser => ligo-parser}/LexToken.mll | 0 src/ligo/{parser => ligo-parser}/Lexer.mli | 0 src/ligo/{parser => ligo-parser}/Lexer.mll | 0 src/ligo/{parser => ligo-parser}/LexerMain.ml | 0 src/ligo/{parser => ligo-parser}/MBytes.ml | 0 src/ligo/{parser => ligo-parser}/MBytes.mli | 0 src/ligo/{parser => ligo-parser}/Markup.ml | 0 src/ligo/{parser => ligo-parser}/Markup.mli | 0 src/ligo/{parser => ligo-parser}/ParToken.mly | 0 src/ligo/{parser => ligo-parser}/Parser.mly | 0 .../{parser => ligo-parser}/ParserMain.ml | 38 +- src/ligo/{parser => ligo-parser}/Pos.ml | 0 src/ligo/{parser => ligo-parser}/Pos.mli | 0 src/ligo/{parser => ligo-parser}/Region.ml | 0 src/ligo/{parser => ligo-parser}/Region.mli | 0 src/ligo/{parser => ligo-parser}/Tests/a.li | 0 .../{parser => ligo-parser}/Typecheck2.ml | 71 ++- .../{parser => ligo-parser}/Typecheck2.mli | 16 +- src/ligo/{parser => ligo-parser}/Utils.ml | 0 src/ligo/{parser => ligo-parser}/Utils.mli | 0 src/ligo/{parser => ligo-parser}/Version.ml | 0 .../check_dot_git_is_dir.sh | 0 src/ligo/{parser => ligo-parser}/dune | 0 .../{parser => ligo-parser}/ligo-parser.opam | 0 src/ligo/ligo-parser/ligo_parser.ml | 7 + src/ligo/{parser => ligo-parser}/typecheck.ml | 0 src/ligo/ligo.ml | 52 +- src/ligo/main.ml | 461 ------------------ src/ligo/mini_c.ml | 12 +- src/ligo/parser.mly | 200 -------- src/ligo/parser/ligo_parser.ml | 1 - src/ligo/test/test.ml | 307 ++++++------ src/ligo/type_ast.ml | 138 ++++++ 64 files changed, 795 insertions(+), 1003 deletions(-) create mode 100644 src/ligo/ast_simplified.ml create mode 100644 src/ligo/ast_typed.ml delete mode 100644 src/ligo/lexer.mll rename src/ligo/{helpers => ligo-helpers}/dictionary.ml (100%) rename src/ligo/{helpers => ligo-helpers}/dictionary.mli (100%) rename src/ligo/{helpers => ligo-helpers}/dune (100%) rename src/ligo/{helpers => ligo-helpers}/environment.ml (100%) rename src/ligo/{helpers => ligo-helpers}/ligo-helpers.opam (100%) rename src/ligo/{helpers => ligo-helpers}/location.ml (100%) rename src/ligo/{helpers => ligo-helpers}/option.ml (100%) rename src/ligo/{helpers => ligo-helpers}/trace.ml (94%) rename src/ligo/{helpers => ligo-helpers}/tree.ml (100%) rename src/ligo/{helpers => ligo-helpers}/wrap.ml (100%) create mode 100644 src/ligo/ligo-helpers/x_map.ml rename src/ligo/{parser => ligo-parser}/.Lexer.ml.tag (100%) rename src/ligo/{parser => ligo-parser}/.LexerMain.tag (100%) rename src/ligo/{parser => ligo-parser}/.Parser.mly.tag (100%) rename src/ligo/{parser => ligo-parser}/.ParserMain.tag (100%) rename src/ligo/{parser => ligo-parser}/.links (100%) rename src/ligo/{parser => ligo-parser}/AST.ml (100%) rename src/ligo/{parser => ligo-parser}/AST.mli (100%) rename src/ligo/{parser => ligo-parser}/AST2.ml (86%) rename src/ligo/{parser => ligo-parser}/Error.mli (100%) rename src/ligo/{parser => ligo-parser}/EvalOpt.ml (100%) rename src/ligo/{parser => ligo-parser}/EvalOpt.mli (100%) rename src/ligo/{parser => ligo-parser}/FQueue.ml (100%) rename src/ligo/{parser => ligo-parser}/FQueue.mli (100%) rename src/ligo/{parser => ligo-parser}/LexToken.mli (100%) rename src/ligo/{parser => ligo-parser}/LexToken.mll (100%) rename src/ligo/{parser => ligo-parser}/Lexer.mli (100%) rename src/ligo/{parser => ligo-parser}/Lexer.mll (100%) rename src/ligo/{parser => ligo-parser}/LexerMain.ml (100%) rename src/ligo/{parser => ligo-parser}/MBytes.ml (100%) rename src/ligo/{parser => ligo-parser}/MBytes.mli (100%) rename src/ligo/{parser => ligo-parser}/Markup.ml (100%) rename src/ligo/{parser => ligo-parser}/Markup.mli (100%) rename src/ligo/{parser => ligo-parser}/ParToken.mly (100%) rename src/ligo/{parser => ligo-parser}/Parser.mly (100%) rename src/ligo/{parser => ligo-parser}/ParserMain.ml (67%) rename src/ligo/{parser => ligo-parser}/Pos.ml (100%) rename src/ligo/{parser => ligo-parser}/Pos.mli (100%) rename src/ligo/{parser => ligo-parser}/Region.ml (100%) rename src/ligo/{parser => ligo-parser}/Region.mli (100%) rename src/ligo/{parser => ligo-parser}/Tests/a.li (100%) rename src/ligo/{parser => ligo-parser}/Typecheck2.ml (55%) rename src/ligo/{parser => ligo-parser}/Typecheck2.mli (90%) rename src/ligo/{parser => ligo-parser}/Utils.ml (100%) rename src/ligo/{parser => ligo-parser}/Utils.mli (100%) rename src/ligo/{parser => ligo-parser}/Version.ml (100%) rename src/ligo/{parser => ligo-parser}/check_dot_git_is_dir.sh (100%) rename src/ligo/{parser => ligo-parser}/dune (100%) rename src/ligo/{parser => ligo-parser}/ligo-parser.opam (100%) create mode 100644 src/ligo/ligo-parser/ligo_parser.ml rename src/ligo/{parser => ligo-parser}/typecheck.ml (100%) delete mode 100644 src/ligo/main.ml delete mode 100644 src/ligo/parser.mly delete mode 100644 src/ligo/parser/ligo_parser.ml create mode 100644 src/ligo/type_ast.ml diff --git a/.gitignore b/.gitignore index b22cc36f4..ed56e0546 100644 --- a/.gitignore +++ b/.gitignore @@ -6,6 +6,7 @@ __pycache__ *.pyc /_build +*/_build /_opam /_docker_build /docs/_build diff --git a/src/ligo/ast_simplified.ml b/src/ligo/ast_simplified.ml new file mode 100644 index 000000000..b121ccd66 --- /dev/null +++ b/src/ligo/ast_simplified.ml @@ -0,0 +1,85 @@ +module SMap = Ligo_helpers.X_map.String + +type name = string +type type_name = string + +type 'a name_map = 'a SMap.t +type 'a type_name_map = 'a SMap.t + +type program = declaration list + +and declaration = + | Type_declaration of named_type_expression + | Constant_declaration of named_expression + (* | Macro_declaration of macro_declaration *) + +and annotated_expression = { + expression: expression ; + type_annotation: te option ; +} + +and named_expression = { + name: name ; + annotated_expression: ae ; +} + +and named_type_expression = { + type_name: type_name ; + type_expression: type_expression ; +} + +and te = type_expression +and ae = annotated_expression +and te_map = type_expression type_name_map +and e_map = expression name_map + +and type_expression = + | Type_tuple of te list + | Type_sum of te_map + | Type_record of te_map + | Type_variable of type_name + | Type_constant of type_name * te list + +and expression = + | Literal of literal + | Constant of name * ae list (* For language constants, like (Cons hd tl) or (plus i j) *) + | Variable of name + | Tuple of ae list + | Constructor of name * ae list (* For user defined constructors *) + | Lambda of { + binder: name ; + input_type: type_expression ; + output_type: type_expression ; + body: block ; + } + +and literal = + | Bool of bool + | Number of int + | String of string + | Bytes of bytes + +and block = instruction list +and b = block + +and instruction = + | Assignment of named_expression + | Matching of matching + | Loop of ae * b + | Skip + | Fail of ae + +and matching = + | Match_bool of { + match_true : b ; + match_false : b ; + } + | Match_list of { + match_nil : b ; + match_cons : name * name * b ; + } + | Match_option of { + match_none : b ; + match_some : name * b ; + } + | Match_tuple of (name * b) list diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml new file mode 100644 index 000000000..2a22d710f --- /dev/null +++ b/src/ligo/ast_typed.ml @@ -0,0 +1,137 @@ +module SMap = Ligo_helpers.X_map.String + +let list_of_smap (s:'a SMap.t) : (string * 'a) list = + List.rev @@ SMap.fold (fun k v p -> (k, v) :: p) s [] + +type name = string +type type_name = string + +type 'a name_map = 'a SMap.t +type 'a type_name_map = 'a SMap.t + +type program = declaration list + +and declaration = + | Constant_declaration of named_expression + (* | Macro_declaration of macro_declaration *) + +and annotated_expression = { + expression: expression ; + type_annotation: tv ; +} + +and named_expression = { + name: name ; + annotated_expression: ae ; +} + +and tv = type_value +and ae = annotated_expression +and tv_map = type_value type_name_map +and e_map = expression name_map + +and type_value = + | Type_tuple of tv list + | Type_sum of tv_map + | Type_record of tv_map + | Type_constant of type_name * tv list + +and expression = + | Literal of literal + | Constant of name * ae list (* For language constants, like (Cons hd tl) or (plus i j) *) + | Variable of name + | Tuple of ae list + | Constructor of name * ae list (* For user defined constructors *) + | Lambda of { + binder: name ; + input_type: type_value ; + output_type: type_value ; + body: block ; + } + +and literal = + | Bool of bool + | Number of int + | String of string + | Bytes of bytes + +and block = instruction list +and b = block + +and instruction = + | Assignment of named_expression + | Matching of matching + | Loop of ae * b + | Skip + | Fail of ae + +and matching = + | Match_bool of { + match_true : b ; + match_false : b ; + } + | Match_list of { + match_nil : b ; + match_cons : name * name * b ; + } + | Match_option of { + match_none : b ; + match_some : name * b ; + } + | Match_tuple of (name * b) list + +open Ligo_helpers.Trace + +let rec type_value_eq (ab: (type_value * type_value)) : unit result = match ab with + | Type_tuple a, Type_tuple b -> ( + let%bind _ = + Assert.assert_true ~msg:"tuples with different sizes" + @@ List.(length a = length b) in + bind_list_iter type_value_eq (List.combine a b) + ) + | Type_constant (a, a'), Type_constant (b, b') -> ( + let%bind _ = + Assert.assert_true ~msg:"constants with different sizes" + @@ List.(length a' = length b') in + let%bind _ = + Assert.assert_true ~msg:"constants with different names" + @@ (a = b) in + trace (simple_error "constant sub-expression") + @@ bind_list_iter type_value_eq (List.combine a' b') + ) + | Type_sum a, Type_sum b -> ( + let a' = list_of_smap a in + let b' = list_of_smap b in + let aux ((ka, va), (kb, vb)) = + let%bind _ = + Assert.assert_true ~msg:"different keys in sum types" + @@ (ka = kb) in + type_value_eq (va, vb) + in + trace (simple_error "sum type") + @@ bind_list_iter aux (List.combine a' b') + + ) + | Type_record a, Type_record b -> ( + let a' = list_of_smap a in + let b' = list_of_smap b in + let aux ((ka, va), (kb, vb)) = + let%bind _ = + Assert.assert_true ~msg:"different keys in record types" + @@ (ka = kb) in + type_value_eq (va, vb) + in + trace (simple_error "record type") + @@ bind_list_iter aux (List.combine a' b') + + ) + | _ -> simple_fail "Different kinds of types" + +let merge_annotation (a:type_value option) (b:type_value option) : type_value option result = + match a, b with + | None, None -> ok None + | Some a, None -> ok (Some a) + | None, Some b -> ok (Some b) + | Some a, Some b -> + let%bind _ = type_value_eq (a, b) in + ok (Some a) diff --git a/src/ligo/bin/cli.ml b/src/ligo/bin/cli.ml index 06135b4a4..306831a00 100644 --- a/src/ligo/bin/cli.ml +++ b/src/ligo/bin/cli.ml @@ -1 +1 @@ -let () = print_int 42 +let () = () diff --git a/src/ligo/dune b/src/ligo/dune index 3d9fc830b..e96ee8c92 100644 --- a/src/ligo/dune +++ b/src/ligo/dune @@ -1,9 +1,3 @@ -(ocamllex - (modules lexer)) - -(menhir - (modules parser)) - (library (name ligo) (public_name ligo) @@ -17,5 +11,5 @@ (preprocess (pps ppx_let) ) - (flags (:standard -w +1..62-4-9-44-40-42@39@33 )) + (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 )) ) diff --git a/src/ligo/lexer.mll b/src/ligo/lexer.mll deleted file mode 100644 index 85f6aec00..000000000 --- a/src/ligo/lexer.mll +++ /dev/null @@ -1,76 +0,0 @@ -{ - open Parser - - exception Error of string - exception Unexpected_character of string -} - -(* This rule analyzes a single line and turns it into a stream of - tokens. *) - -rule token = parse -(* - | "//" ([^ '\n']* ) (['\n' '\r']+) - { Lexing.new_line lexbuf ; token lexbuf } -*) -| ('\r'? '\n' '\r'?) - { Lexing.new_line lexbuf; token lexbuf } -| [' ' '\t'] - { token lexbuf } -| '"' ( [^ '"' '\\'] | ( '\\' [^ '"'] ) ) as s '"' - { STRING s } -| "let" { LET } -| "if" { IF } -(* | "then" { THEN } *) -| "elseif" { ELSEIF } -| "else" { ELSE } -(* | "in" { IN } *) -| "type" { TYPE } -| "function" { FUNCTION } -| "while" - { WHILE } -| "foreach" - { FOREACH } -| "of" - { OF } -| (['a'-'z']['a'-'z''A'-'Z''0'-'9''_']+) as v - { VAR_NAME v } -| (['A'-'Z']['a'-'z''A'-'Z''0'-'9''_']+) as t - { TYPE_NAME t } -(* | ['0'-'9']+'.'['0'-'9']* as i { FLOAT (float_of_string i) } *) -| ['0'-'9']+ as i - { INT (int_of_string i) } -(* - | '+' { PLUS } - | '-' { MINUS } - | '*' { TIMES } - | '/' { DIV } - | ";;" { DOUBLE_SEMICOLON } -*) -| '=' { EQUAL } -| ',' { COMMA } -| ';' { SEMICOLON } -| ':' { COLON } -| '&' - { AND } -| '|' - { AND } -| '.' - { DOT } -| '@' - { AT } -| '(' - { LPAREN } -| ')' - { RPAREN } -(* - | '[' { LSQUARE } - | ']' { RSQUARE } -*) -| '{' - { LBRACKET } -| '}' - { RBRACKET } -| eof { EOF } -| _ - { raise (Unexpected_character (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) } diff --git a/src/ligo/helpers/dictionary.ml b/src/ligo/ligo-helpers/dictionary.ml similarity index 100% rename from src/ligo/helpers/dictionary.ml rename to src/ligo/ligo-helpers/dictionary.ml diff --git a/src/ligo/helpers/dictionary.mli b/src/ligo/ligo-helpers/dictionary.mli similarity index 100% rename from src/ligo/helpers/dictionary.mli rename to src/ligo/ligo-helpers/dictionary.mli diff --git a/src/ligo/helpers/dune b/src/ligo/ligo-helpers/dune similarity index 100% rename from src/ligo/helpers/dune rename to src/ligo/ligo-helpers/dune diff --git a/src/ligo/helpers/environment.ml b/src/ligo/ligo-helpers/environment.ml similarity index 100% rename from src/ligo/helpers/environment.ml rename to src/ligo/ligo-helpers/environment.ml diff --git a/src/ligo/helpers/ligo-helpers.opam b/src/ligo/ligo-helpers/ligo-helpers.opam similarity index 100% rename from src/ligo/helpers/ligo-helpers.opam rename to src/ligo/ligo-helpers/ligo-helpers.opam diff --git a/src/ligo/helpers/location.ml b/src/ligo/ligo-helpers/location.ml similarity index 100% rename from src/ligo/helpers/location.ml rename to src/ligo/ligo-helpers/location.ml diff --git a/src/ligo/helpers/option.ml b/src/ligo/ligo-helpers/option.ml similarity index 100% rename from src/ligo/helpers/option.ml rename to src/ligo/ligo-helpers/option.ml diff --git a/src/ligo/helpers/trace.ml b/src/ligo/ligo-helpers/trace.ml similarity index 94% rename from src/ligo/helpers/trace.ml rename to src/ligo/ligo-helpers/trace.ml index a99e7ea8b..a3dc4e7f2 100644 --- a/src/ligo/helpers/trace.ml +++ b/src/ligo/ligo-helpers/trace.ml @@ -50,6 +50,17 @@ let rec bind_list = function ok @@ hd :: tl ) +let bind_fold_list f init lst = + let aux x y = + x >>? fun x -> + f x y + in + List.fold_left aux (ok init) lst + +let bind_list_iter f lst = + let aux () y = f y in + bind_fold_list aux () lst + let bind_or (a, b) = match a with | Ok x -> ok x diff --git a/src/ligo/helpers/tree.ml b/src/ligo/ligo-helpers/tree.ml similarity index 100% rename from src/ligo/helpers/tree.ml rename to src/ligo/ligo-helpers/tree.ml diff --git a/src/ligo/helpers/wrap.ml b/src/ligo/ligo-helpers/wrap.ml similarity index 100% rename from src/ligo/helpers/wrap.ml rename to src/ligo/ligo-helpers/wrap.ml diff --git a/src/ligo/ligo-helpers/x_map.ml b/src/ligo/ligo-helpers/x_map.ml new file mode 100644 index 000000000..e5a3d15e4 --- /dev/null +++ b/src/ligo/ligo-helpers/x_map.ml @@ -0,0 +1 @@ +module String = Map.Make(String) diff --git a/src/ligo/parser/.Lexer.ml.tag b/src/ligo/ligo-parser/.Lexer.ml.tag similarity index 100% rename from src/ligo/parser/.Lexer.ml.tag rename to src/ligo/ligo-parser/.Lexer.ml.tag diff --git a/src/ligo/parser/.LexerMain.tag b/src/ligo/ligo-parser/.LexerMain.tag similarity index 100% rename from src/ligo/parser/.LexerMain.tag rename to src/ligo/ligo-parser/.LexerMain.tag diff --git a/src/ligo/parser/.Parser.mly.tag b/src/ligo/ligo-parser/.Parser.mly.tag similarity index 100% rename from src/ligo/parser/.Parser.mly.tag rename to src/ligo/ligo-parser/.Parser.mly.tag diff --git a/src/ligo/parser/.ParserMain.tag b/src/ligo/ligo-parser/.ParserMain.tag similarity index 100% rename from src/ligo/parser/.ParserMain.tag rename to src/ligo/ligo-parser/.ParserMain.tag diff --git a/src/ligo/parser/.links b/src/ligo/ligo-parser/.links similarity index 100% rename from src/ligo/parser/.links rename to src/ligo/ligo-parser/.links diff --git a/src/ligo/parser/AST.ml b/src/ligo/ligo-parser/AST.ml similarity index 100% rename from src/ligo/parser/AST.ml rename to src/ligo/ligo-parser/AST.ml diff --git a/src/ligo/parser/AST.mli b/src/ligo/ligo-parser/AST.mli similarity index 100% rename from src/ligo/parser/AST.mli rename to src/ligo/ligo-parser/AST.mli diff --git a/src/ligo/parser/AST2.ml b/src/ligo/ligo-parser/AST2.ml similarity index 86% rename from src/ligo/parser/AST2.ml rename to src/ligo/ligo-parser/AST2.ml index c91612138..b71c7f472 100644 --- a/src/ligo/parser/AST2.ml +++ b/src/ligo/ligo-parser/AST2.ml @@ -7,15 +7,13 @@ open Region module SMap = Map.Make(String) module O = struct - type asttodo = [`TODO] + type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) type name_and_region = {name: string; orig: Region.t} type type_name = name_and_region type var_name = name_and_region type field_name = name_and_region - type record_key = [`Field of field_name | `Component of int] - type pattern = PVar of var_name | PWild @@ -29,9 +27,7 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of record_key precord - - and 'key precord = ('key * pattern) list + | PRecord of (field_name * pattern) SMap.t type type_constructor = Option @@ -40,8 +36,8 @@ module O = struct | Map type type_expr_case = - Sum of (type_name * type_expr) list - | Record of record_key type_record + Sum of (type_name * type_expr) SMap.t + | Record of (field_name * type_expr) SMap.t | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr @@ -49,18 +45,18 @@ module O = struct | Int | Unit | Bool - and 'key type_record = ('key * type_expr) list and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t } - type typed_var = { name:var_name; ty:type_expr } + type typed_var = { name:var_name; ty:type_expr; orig: asttodo } - type type_decl = { name:type_name; ty:type_expr } + type type_decl = { name:type_name; ty:type_expr; orig: asttodo } type expr = App of { operator: operator; arguments: expr list } | Var of var_name | Constant of constant + | Record of (field_name * expr) list | Lambda of lambda and decl = { name:var_name; ty:type_expr; value: expr } @@ -73,33 +69,36 @@ module O = struct } and operator = - Function of var_name - | Construcor of var_name - | UpdateField of record_key - | GetField of record_key - | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod - | Neg | Not - | Tuple | Set | List - | MapLookup + Function of var_name + | Constructor of var_name + | UpdateField of field_name + | GetField of field_name + | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod + | Neg | Not + | Set | List + | MapLookup and constant = - Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True - | Null of type_expr | EmptySet of type_expr | CNone of type_expr + Unit + | Int of Z.t | String of string | Bytes of MBytes.t + | False | True + | Null of type_expr + | EmptySet of type_expr + | CNone of type_expr and instr = - Assignment of { name: var_name; value: expr } - | While of { condition: expr; body: instr list } - | ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list } - | If of { condition: expr; ifso: instr list; ifnot: instr list } - | Match of { expr: expr; cases: (pattern * instr list) list } - | DropUnit of expr (* expr returns unit, drop the result. *) - | Fail of { expr: expr } + Assignment of { name: var_name; value: expr; orig: asttodo } + | While of { condition: expr; body: instr list; orig: asttodo } + | ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo } + | Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo } + | ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) + | Fail of { expr: expr; orig: asttodo } type ast = { types : type_decl list; storage_decl : typed_var; - operations_decl : typed_var; declarations : decl list; + orig : AST.t } end @@ -126,6 +125,8 @@ let fold_map f a l = (* Simplify the AST *) +let name_and_region_of_int i = O.{name = string_of_int i; orig = Region.ghost} + let s_nsepseq : ('a,'sep) Utils.nsepseq -> 'a list = fun (first, rest) -> first :: (map snd rest) @@ -155,17 +156,26 @@ let s_type_constructor {value=name;region} : O.type_constructor = (* TODO: escape the name, prevent any \x1b and other weird characters from appearing in the output *) | _ -> failwith ("Unknown type constructor: " ^ name) +let named_list_to_map (l : (O.name_and_region * 'a) list) : (O.name_and_region * 'a) SMap.t = + List.fold_left + (fun m ((x,_) as p) -> + let {name;_} : O.name_and_region = x in + SMap.add name p m) + SMap.empty + l + let rec s_cartesian {value=sequence; region} : O.type_expr = let () = ignore (region) in s_nsepseq sequence |>map s_type_expr - |> mapi (fun i p -> `Component i, p) + |> mapi (fun i p -> name_and_region_of_int i, p) + |> named_list_to_map |> (fun x -> (Record x : O.type_expr_case)) |> type_expr region and s_sum_type {value=sequence; region} : O.type_expr = let () = ignore (region) in - type_expr region (Sum (map s_variant (s_nsepseq sequence))) + type_expr region (Sum (map s_variant (s_nsepseq sequence) |> named_list_to_map)) and s_variant {value=(constr, kwd_of, cartesian); region} = let () = ignore (kwd_of,region) in @@ -173,11 +183,11 @@ and s_variant {value=(constr, kwd_of, cartesian); region} = and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr = let () = ignore (kwd_record,region,kwd_end) in - type_expr region (Record (map s_field_decl (s_nsepseq field_decls))) + type_expr region (Record (map s_field_decl (s_nsepseq field_decls) |> named_list_to_map) : O.type_expr_case) -and s_field_decl {value=(var, colon, type_expr); region} = +and s_field_decl {value=(var, colon, type_expr); region} : O.type_name * O.type_expr = let () = ignore (colon,region) in - (`Field (s_name var), s_type_expr type_expr) + ((s_name var), (s_type_expr type_expr)) and s_type_app {value=(type_name,type_tuple); region} : O.type_expr = let () = ignore (region) in @@ -208,15 +218,15 @@ and s_type_expr (orig : I.type_expr) : O.type_expr = match orig with let s_type_decl I.{value={kwd_type;name;kwd_is;type_expr;terminator}; region} : O.type_decl = let () = ignore (kwd_type,kwd_is,terminator,region) in let ty = s_type_expr type_expr in - O.{ name = s_name name; ty = { ty with name = Some (s_name name) } } + O.{ name = s_name name; ty = { ty with name = Some (s_name name) }; orig = `TODO } let s_storage_decl I.{value={kwd_storage; name; colon; store_type; terminator}; region} : O.typed_var = let () = ignore (kwd_storage,colon,terminator,region) in - O.{ name = s_name name; ty = s_type_expr store_type } + O.{ name = s_name name; ty = s_type_expr store_type; orig = `TODO } let s_operations_decl I.{value={kwd_operations;name;colon;op_type;terminator}; region} : O.typed_var = let () = ignore (kwd_operations,colon,terminator,region) in - O.{ name = s_name name; ty = s_type_expr op_type } + O.{ name = s_name name; ty = s_type_expr op_type; orig = `TODO } let s_empty_list {value=(l, (lbracket, rbracket, colon, type_expr), r); region} : O.expr = let () = ignore (l, lbracket, rbracket, colon, r, region) in @@ -232,13 +242,15 @@ let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr = let parameters_to_tuple (parameters : (string * O.type_expr) list) : O.type_expr = (* TODO: use records with named fields to have named arguments. *) - let parameter_tuple = O.Record (mapi (fun i (_name,ty) -> `Component i, ty) parameters) in + let parameter_tuple : O.type_expr_case = + Record (mapi (fun i (_name,ty) -> name_and_region_of_int i, ty) parameters |> named_list_to_map) in O.{ type_expr = parameter_tuple; name = None; orig = Region.ghost } + and parameters_to_decls singleparam (parameters : (string * O.type_expr) list) : O.decl list = let f i (name,ty) = O.{ name = {name; orig=Region.ghost}; ty = ty; - value = App { operator = O.GetField (`Component i); + value = App { operator = O.GetField (name_and_region_of_int i); arguments = [Var singleparam] } } in mapi f parameters @@ -270,7 +282,7 @@ and s_expr : I.expr -> O.expr = | False c_False -> let () = ignore (c_False) in Constant (False) | True c_True -> let () = ignore (c_True) in Constant (True) | Unit c_Unit -> let () = ignore (c_Unit) in Constant (Unit) - | Tuple {value=(l,tuple,r); region} -> let () = ignore (l,r,region) in App { operator = Tuple; arguments = map s_expr (s_nsepseq tuple)} + | Tuple {value=(l,tuple,r); region} -> let () = ignore (l,r,region) in s_tuple_expr (tuple |> s_nsepseq |> map s_expr) | List list -> s_list list | EmptyList empty_list -> s_empty_list empty_list | Set set -> s_set set @@ -282,6 +294,9 @@ and s_expr : I.expr -> O.expr = | MapLookUp map_lookup -> s_map_lookup map_lookup | ParExpr {value=(lpar,expr,rpar); region} -> let () = ignore (lpar,rpar,region) in s_expr expr +and s_tuple_expr tuple : O.expr = + Record (mapi (fun i e -> name_and_region_of_int i, e) tuple) + and s_map_lookup I.{value = {map_name; selector; index}; region} : O.expr = let {value = lbracket, index_expr, rbracket; region=region2} = index in let () = ignore (selector, lbracket, rbracket, region2, region) in @@ -292,7 +307,7 @@ and s_some_app {value=(c_Some, {value=(l,arguments,r); region=region2}); region} match s_nsepseq arguments with [] -> failwith "tuple cannot be empty" | [a] -> s_expr a - | l -> App { operator = Tuple; arguments = map s_expr l } + | l -> s_tuple_expr (map s_expr l) and s_list {value=(l, list, r); region} : O.expr = let () = ignore (l, r, region) in @@ -347,8 +362,8 @@ and s_ptuple {value=(lpar, sequence, rpar); region} = let () = ignore (lpar, rpar, region) in s_nsepseq sequence |> map s_core_pattern - |> mapi (fun i p -> `Component i, p) - |> fun x -> O.PRecord x + |> mapi (fun i p -> name_and_region_of_int i, p) + |> fun x -> O.PRecord (x |> named_list_to_map) and s_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern = let () = ignore (c_Some,l,r,region2,region) in @@ -398,20 +413,27 @@ and s_instruction : I.instruction -> O.instr list = function and s_conditional I.{kwd_if;test;kwd_then;ifso;kwd_else;ifnot} : O.instr = let () = ignore (kwd_if,kwd_then,kwd_else) in - If { condition = s_expr test; ifso = s_instruction ifso; ifnot = s_instruction ifnot } + let test = s_expr test in + let ifso = O.PTrue, s_instruction ifso in + let ifnot = O.PFalse, s_instruction ifnot in + Match { + expr = test; + cases = [ifso; ifnot]; + orig = `TODO + } and s_match_instr I.{kwd_match;expr;kwd_with;lead_vbar;cases;kwd_end} : O.instr = let {value=cases;region} = cases in let () = ignore (kwd_match,kwd_with,lead_vbar,kwd_end,region) in - Match { expr = s_expr expr; cases = map s_case (s_nsepseq cases) } + Match { expr = s_expr expr; cases = map s_case (s_nsepseq cases); orig = `TODO } and s_ass_instr {value=(variable,ass,expr); region} : O.instr = let () = ignore (ass,region) in - Assignment { name = s_name variable; value = s_expr expr } + Assignment { name = s_name variable; value = s_expr expr; orig = `TODO } and s_while_loop {value=(kwd_while, expr, block); region} : O.instr list = let () = ignore (kwd_while,region) in - [While {condition = s_expr expr; body = s_block block}] + [While {condition = s_expr expr; body = s_block block; orig = `TODO}] and s_for_loop : I.for_loop -> O.instr list = function ForInt for_int -> s_for_int for_int @@ -425,28 +447,34 @@ and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : I.fo | None -> O.Lt, O.Add in let step = s_step step in [ - Assignment { name; value = s_expr expr }; + Assignment { name; value = s_expr expr; orig = `TODO }; (* TODO: lift the declaration of the variable, to avoid creating a nested scope here. *) While { condition = App { operator = condition; - arguments = [Var name; s_expr bound] }; + arguments = [Var name; s_expr bound]}; body = append (s_block block) [O.Assignment { name; value = App { operator; - arguments = [Var name; step]}}] + arguments = [Var name; step]}; + orig = `TODO }]; + orig = `TODO } ] and s_for_collect ({value={kwd_for;var;bind_to;kwd_in;expr;block}; _} : I.for_collect reg) : O.instr list = let () = ignore (kwd_for,kwd_in) in - [ - O.ForCollection { - list = s_expr expr; - key = s_name var; - value = s_bind_to bind_to; - body = s_block block - } - ] + let for_instr = + match s_bind_to bind_to with + Some _ -> + failwith "TODO: For on maps is not supported yet!" + | None -> + O.ForCollection { + list = s_expr expr; + var = s_name var; + body = s_block block; + orig = `TODO + } + in [for_instr] and s_step : (I.kwd_step * I.expr) option -> O.expr = function Some (kwd_step, expr) -> let () = ignore (kwd_step) in s_expr expr @@ -462,7 +490,13 @@ and s_loop : I.loop -> O.instr list = function and s_fun_call {value=(fun_name, arguments); region} : O.expr = let () = ignore (region) in - App { operator = Function (s_name fun_name); arguments = s_arguments arguments } + let {value=fun_name_string;_} = fun_name in + let firstchar = String.sub fun_name_string 0 1 in + (* If it starts with a capital letter, then it is a constructor *) + if String.equal firstchar (String.uppercase_ascii firstchar) then + App { operator = Constructor (s_name fun_name); arguments = s_arguments arguments } + else + App { operator = Function (s_name fun_name); arguments = s_arguments arguments } and s_constr_app {value=(constr, arguments); region} : O.expr = let () = ignore (region) in @@ -474,11 +508,11 @@ and s_arguments {value=(lpar, sequence, rpar); region} : O.expr list = match map s_expr (s_nsepseq sequence) with [] -> [Constant Unit] | [single_argument] -> [single_argument] - | args -> [App { operator = Tuple; arguments = args }] ; + | args -> [s_tuple_expr args] ; and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr = let () = ignore (kwd_fail) in - Fail { expr = s_expr expr } + Fail { expr = s_expr expr; orig = `TODO } @@ -488,7 +522,7 @@ and s_single_instr : I.single_instr -> O.instr list = function | Match {value; _} -> [s_match_instr value] | Ass instr -> [s_ass_instr instr] | Loop loop -> s_loop loop -| ProcCall fun_call -> [DropUnit (s_fun_call fun_call)] +| ProcCall fun_call -> [ProcedureCall { expr = s_fun_call fun_call; orig = `TODO }] | Null kwd_null -> let () = ignore (kwd_null) in [] | Fail {value; _} -> [s_fail value] @@ -502,13 +536,13 @@ and gensym = fun ty -> i := !i + 1; (* TODO: Region.ghost *) - ({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty} : O.typed_var) + ({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty; orig = `TODO} : O.typed_var) and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_decls;block;kwd_with;return;terminator}; region} : O.decl = let () = ignore (kwd_function,colon,kwd_is,kwd_with,terminator,region) in let tuple_type = s_parameters param |> parameters_to_tuple in let single_argument = gensym tuple_type in - let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in + let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in O.{ name = s_name name; ty = type_expr region (Function { arg = tuple_type; @@ -527,7 +561,7 @@ and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;term let () = ignore (kwd_procedure,kwd_is,terminator,region) in let tuple_type = s_parameters param |> parameters_to_tuple in let single_argument = gensym tuple_type in - let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in + let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in O.{ name = s_name name; ty = type_expr region (Function { arg = tuple_type; @@ -546,7 +580,7 @@ and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;te let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in let tuple_type = s_parameters param |> parameters_to_tuple in let single_argument = gensym tuple_type in - let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in + let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in O.{ name = s_name name; ty = type_expr region (Function { arg = tuple_type; @@ -594,10 +628,10 @@ let s_ast (ast : I.ast) : O.ast = let storage_decl = match storage_decl with Some x -> x | None -> failwith "Missing storage declaration" in - let operations_decl = match operations_decl with - Some x -> x - | None -> failwith "Missing storage declaration" - in {types; storage_decl; operations_decl; declarations} + let () = match operations_decl with + Some _ -> failwith "Operations declaration is not allowed anymore TODO" + | None -> () + in {types; storage_decl; declarations; orig = ast} diff --git a/src/ligo/parser/Error.mli b/src/ligo/ligo-parser/Error.mli similarity index 100% rename from src/ligo/parser/Error.mli rename to src/ligo/ligo-parser/Error.mli diff --git a/src/ligo/parser/EvalOpt.ml b/src/ligo/ligo-parser/EvalOpt.ml similarity index 100% rename from src/ligo/parser/EvalOpt.ml rename to src/ligo/ligo-parser/EvalOpt.ml diff --git a/src/ligo/parser/EvalOpt.mli b/src/ligo/ligo-parser/EvalOpt.mli similarity index 100% rename from src/ligo/parser/EvalOpt.mli rename to src/ligo/ligo-parser/EvalOpt.mli diff --git a/src/ligo/parser/FQueue.ml b/src/ligo/ligo-parser/FQueue.ml similarity index 100% rename from src/ligo/parser/FQueue.ml rename to src/ligo/ligo-parser/FQueue.ml diff --git a/src/ligo/parser/FQueue.mli b/src/ligo/ligo-parser/FQueue.mli similarity index 100% rename from src/ligo/parser/FQueue.mli rename to src/ligo/ligo-parser/FQueue.mli diff --git a/src/ligo/parser/LexToken.mli b/src/ligo/ligo-parser/LexToken.mli similarity index 100% rename from src/ligo/parser/LexToken.mli rename to src/ligo/ligo-parser/LexToken.mli diff --git a/src/ligo/parser/LexToken.mll b/src/ligo/ligo-parser/LexToken.mll similarity index 100% rename from src/ligo/parser/LexToken.mll rename to src/ligo/ligo-parser/LexToken.mll diff --git a/src/ligo/parser/Lexer.mli b/src/ligo/ligo-parser/Lexer.mli similarity index 100% rename from src/ligo/parser/Lexer.mli rename to src/ligo/ligo-parser/Lexer.mli diff --git a/src/ligo/parser/Lexer.mll b/src/ligo/ligo-parser/Lexer.mll similarity index 100% rename from src/ligo/parser/Lexer.mll rename to src/ligo/ligo-parser/Lexer.mll diff --git a/src/ligo/parser/LexerMain.ml b/src/ligo/ligo-parser/LexerMain.ml similarity index 100% rename from src/ligo/parser/LexerMain.ml rename to src/ligo/ligo-parser/LexerMain.ml diff --git a/src/ligo/parser/MBytes.ml b/src/ligo/ligo-parser/MBytes.ml similarity index 100% rename from src/ligo/parser/MBytes.ml rename to src/ligo/ligo-parser/MBytes.ml diff --git a/src/ligo/parser/MBytes.mli b/src/ligo/ligo-parser/MBytes.mli similarity index 100% rename from src/ligo/parser/MBytes.mli rename to src/ligo/ligo-parser/MBytes.mli diff --git a/src/ligo/parser/Markup.ml b/src/ligo/ligo-parser/Markup.ml similarity index 100% rename from src/ligo/parser/Markup.ml rename to src/ligo/ligo-parser/Markup.ml diff --git a/src/ligo/parser/Markup.mli b/src/ligo/ligo-parser/Markup.mli similarity index 100% rename from src/ligo/parser/Markup.mli rename to src/ligo/ligo-parser/Markup.mli diff --git a/src/ligo/parser/ParToken.mly b/src/ligo/ligo-parser/ParToken.mly similarity index 100% rename from src/ligo/parser/ParToken.mly rename to src/ligo/ligo-parser/ParToken.mly diff --git a/src/ligo/parser/Parser.mly b/src/ligo/ligo-parser/Parser.mly similarity index 100% rename from src/ligo/parser/Parser.mly rename to src/ligo/ligo-parser/Parser.mly diff --git a/src/ligo/parser/ParserMain.ml b/src/ligo/ligo-parser/ParserMain.ml similarity index 67% rename from src/ligo/parser/ParserMain.ml rename to src/ligo/ligo-parser/ParserMain.ml index 66b96fbca..2c2fe2791 100644 --- a/src/ligo/parser/ParserMain.ml +++ b/src/ligo/ligo-parser/ParserMain.ml @@ -34,12 +34,40 @@ let lib_path = in List.fold_right mk_I libs "" *) +(* Preprocessing the input source and opening the input channels *) + +let prefix = + match EvalOpt.input with + None | Some "-" -> "temp" + | Some file -> Filename.(file |> basename |> remove_extension) + +let suffix = ".pp.li" + +let pp_input = + if Utils.String.Set.mem "cpp" EvalOpt.verbose + then prefix ^ suffix + else let pp_input, pp_out = Filename.open_temp_file prefix suffix + in close_out pp_out; pp_input + +let cpp_cmd = + match EvalOpt.input with + None | Some "-" -> + Printf.sprintf "cpp -traditional-cpp - -o %s" pp_input + | Some file -> + Printf.sprintf "cpp -traditional-cpp %s -o %s" file pp_input + +let () = + if Utils.String.Set.mem "cpp" EvalOpt.verbose + then Printf.eprintf "%s\n%!" cpp_cmd; + if Sys.command cpp_cmd <> 0 then + external_ (Printf.sprintf "the command \"%s\" failed." cpp_cmd) + (* Instanciating the lexer *) module Lexer = Lexer.Make (LexToken) let Lexer.{read; buffer; get_pos; get_last; close} = - Lexer.open_token_stream EvalOpt.input + Lexer.open_token_stream (Some pp_input) and cout = stdout @@ -78,6 +106,8 @@ let () = (* Temporary: force dune to build AST2.ml *) let () = - let open Typecheck2 in - let _ = temporary_force_dune in - () + if false then + let _ = Typecheck2.annotate in + () + else + () diff --git a/src/ligo/parser/Pos.ml b/src/ligo/ligo-parser/Pos.ml similarity index 100% rename from src/ligo/parser/Pos.ml rename to src/ligo/ligo-parser/Pos.ml diff --git a/src/ligo/parser/Pos.mli b/src/ligo/ligo-parser/Pos.mli similarity index 100% rename from src/ligo/parser/Pos.mli rename to src/ligo/ligo-parser/Pos.mli diff --git a/src/ligo/parser/Region.ml b/src/ligo/ligo-parser/Region.ml similarity index 100% rename from src/ligo/parser/Region.ml rename to src/ligo/ligo-parser/Region.ml diff --git a/src/ligo/parser/Region.mli b/src/ligo/ligo-parser/Region.mli similarity index 100% rename from src/ligo/parser/Region.mli rename to src/ligo/ligo-parser/Region.mli diff --git a/src/ligo/parser/Tests/a.li b/src/ligo/ligo-parser/Tests/a.li similarity index 100% rename from src/ligo/parser/Tests/a.li rename to src/ligo/ligo-parser/Tests/a.li diff --git a/src/ligo/parser/Typecheck2.ml b/src/ligo/ligo-parser/Typecheck2.ml similarity index 55% rename from src/ligo/parser/Typecheck2.ml rename to src/ligo/ligo-parser/Typecheck2.ml index 3edc1b66b..d748a23e9 100644 --- a/src/ligo/parser/Typecheck2.ml +++ b/src/ligo/ligo-parser/Typecheck2.ml @@ -1,7 +1,11 @@ +[@@@warning "-27"] (* TODO *) +[@@@warning "-32"] (* TODO *) [@@@warning "-30"] module SMap = Map.Make(String) +module I = AST2.O + module O = struct type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) @@ -23,7 +27,7 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of (field_name * pattern) list + | PRecord of (field_name * pattern) SMap.t type type_constructor = Option @@ -32,8 +36,8 @@ module O = struct | Map type type_expr_case = - Sum of (type_name * type_expr) list - | Record of (field_name * type_expr) list + Sum of (type_name * type_expr) SMap.t + | Record of (field_name * type_expr) SMap.t | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr @@ -42,7 +46,7 @@ module O = struct | Unit | Bool - and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } + and type_expr = { type_expr: type_expr_case; name: string option; orig: Region.t } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } @@ -68,7 +72,7 @@ module O = struct and operator_case = Function of var_name - | Construcor of var_name + | Constructor of var_name | UpdateField of field_name | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod @@ -98,8 +102,61 @@ module O = struct types : type_decl list; storage_decl : typed_var; declarations : decl list; - orig: AST.t + orig : AST.t } end -let temporary_force_dune = 123 +type te = O.type_expr list SMap.t +type ve = O.type_expr list SMap.t +type tve = te * ve + +let fold_map f a l = + let f (acc, l) elem = + let acc', elem' = f acc elem + in acc', (elem' :: l) in + let last_acc, last_l = List.fold_left f (a, []) l + in last_acc, List.rev last_l + +let a_type_constructor (tve : tve) : I.type_constructor -> O.type_constructor = function + Option -> failwith "TODO" +| List -> failwith "TODO" +| Set -> failwith "TODO" +| Map -> failwith "TODO" + +let a_type_expr_case (tve : tve) : I.type_expr_case -> O.type_expr_case = function + Sum l -> failwith "TODO" + | Record l -> failwith "TODO" + | TypeApp (tc, args) -> failwith "TODO" + | Function {arg;ret} -> failwith "TODO" + | Ref t -> failwith "TODO" + | String -> failwith "TODO" + | Int -> failwith "TODO" + | Unit -> failwith "TODO" + | Bool -> failwith "TODO" + + +let a_type_expr (tve : tve) ({type_expr;name;orig} : I.type_expr) : O.type_expr = + failwith "TODO" + +let a_type (tve : tve) ({name;ty;orig} : I.type_decl) : tve * O.type_decl = + failwith "TODO" + +let a_types (tve : tve) (l : I.type_decl list) : tve * O.type_decl list = + fold_map a_type tve l + +let a_storage_decl : tve -> I.typed_var -> tve * O.typed_var = + failwith "TODO" + +let a_declarations : tve -> I.decl list -> tve * O.decl list = + failwith "TODO" + +let a_ast I.{types; storage_decl; declarations; orig} = + let tve = SMap.empty, SMap.empty in + let tve, types = a_types tve types in + let tve, storage_decl = a_storage_decl tve storage_decl in + let tve, declarations = a_declarations tve declarations in + let _ = tve in + O.{types; storage_decl; declarations; orig} + +let annotate : I.ast -> O.ast = a_ast + diff --git a/src/ligo/parser/Typecheck2.mli b/src/ligo/ligo-parser/Typecheck2.mli similarity index 90% rename from src/ligo/parser/Typecheck2.mli rename to src/ligo/ligo-parser/Typecheck2.mli index a85ddba8b..26a1011c9 100644 --- a/src/ligo/parser/Typecheck2.mli +++ b/src/ligo/ligo-parser/Typecheck2.mli @@ -2,6 +2,8 @@ module SMap : Map.S with type key = string +module I = AST2.O + module O : sig type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) @@ -23,7 +25,7 @@ module O : sig | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of (field_name * pattern) list + | PRecord of (field_name * pattern) SMap.t type type_constructor = Option @@ -32,8 +34,8 @@ module O : sig | Map type type_expr_case = - Sum of (type_name * type_expr) list - | Record of (field_name * type_expr) list + Sum of (type_name * type_expr) SMap.t + | Record of (field_name * type_expr) SMap.t | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr @@ -42,7 +44,7 @@ module O : sig | Unit | Bool - and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } + and type_expr = { type_expr: type_expr_case; name: string option; orig: Region.t } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } @@ -68,7 +70,7 @@ module O : sig and operator_case = Function of var_name - | Construcor of var_name + | Constructor of var_name | UpdateField of field_name | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod @@ -98,8 +100,8 @@ module O : sig types : type_decl list; storage_decl : typed_var; declarations : decl list; - orig: AST.t + orig : AST.t } end -val temporary_force_dune : int +val annotate : I.ast -> O.ast diff --git a/src/ligo/parser/Utils.ml b/src/ligo/ligo-parser/Utils.ml similarity index 100% rename from src/ligo/parser/Utils.ml rename to src/ligo/ligo-parser/Utils.ml diff --git a/src/ligo/parser/Utils.mli b/src/ligo/ligo-parser/Utils.mli similarity index 100% rename from src/ligo/parser/Utils.mli rename to src/ligo/ligo-parser/Utils.mli diff --git a/src/ligo/parser/Version.ml b/src/ligo/ligo-parser/Version.ml similarity index 100% rename from src/ligo/parser/Version.ml rename to src/ligo/ligo-parser/Version.ml diff --git a/src/ligo/parser/check_dot_git_is_dir.sh b/src/ligo/ligo-parser/check_dot_git_is_dir.sh similarity index 100% rename from src/ligo/parser/check_dot_git_is_dir.sh rename to src/ligo/ligo-parser/check_dot_git_is_dir.sh diff --git a/src/ligo/parser/dune b/src/ligo/ligo-parser/dune similarity index 100% rename from src/ligo/parser/dune rename to src/ligo/ligo-parser/dune diff --git a/src/ligo/parser/ligo-parser.opam b/src/ligo/ligo-parser/ligo-parser.opam similarity index 100% rename from src/ligo/parser/ligo-parser.opam rename to src/ligo/ligo-parser/ligo-parser.opam diff --git a/src/ligo/ligo-parser/ligo_parser.ml b/src/ligo/ligo-parser/ligo_parser.ml new file mode 100644 index 000000000..2fbdbb47e --- /dev/null +++ b/src/ligo/ligo-parser/ligo_parser.ml @@ -0,0 +1,7 @@ +module Parser = Parser +module Lexer = Lexer.Make(LexToken) +module AST = AST +module AST2 = AST2 +module Typed = Typecheck2 + +let ast_to_typed_ast ast = ast |> AST2.s_ast |> Typed.annotate diff --git a/src/ligo/parser/typecheck.ml b/src/ligo/ligo-parser/typecheck.ml similarity index 100% rename from src/ligo/parser/typecheck.ml rename to src/ligo/ligo-parser/typecheck.ml diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 28f431fa9..5ddc8ff42 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -1,5 +1,53 @@ -include Main +open Ligo_parser -module Mini_c = Mini_c module Parser = Parser module Lexer = Lexer +module CST = AST +module AST = AST2 +module Typed = Typed +module Mini_c = Mini_c + +open Ligo_helpers.Trace +let parse_file (source:string) : CST.t result = + let channel = open_in source in + let lexbuf = Lexing.from_channel channel in + let Lexer.{read ; _} = + Lexer.open_token_stream None in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> Parser.program read lexbuf) >>? fun program_cst -> + ok program_cst + +let parse (s:string) : CST.t result = + let lexbuf = Lexing.from_string s in + let Lexer.{read ; _} = + Lexer.open_token_stream None in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> Parser.program read lexbuf) >>? fun program_cst -> + ok program_cst + + +let abstract (cst:CST.t) : AST.O.ast result = ok @@ AST.s_ast cst + +let annotate_types (ast:AST.O.ast) = ok @@ Typed.annotate ast diff --git a/src/ligo/main.ml b/src/ligo/main.ml deleted file mode 100644 index 5b937b980..000000000 --- a/src/ligo/main.ml +++ /dev/null @@ -1,461 +0,0 @@ -(* -*- compile-command: "cd .. ; dune build -p ligo" -*- *) - -open Ligo_helpers -open Trace - -module Untyped = struct - module WrapLocation = Wrap.Location - let wrap = Wrap.Location.make - - module Type = struct - type name = string - - type base = [ - | `Unit - | `Bool - | `Int - | `Nat - ] - - let unit : base = `Unit - let bool : base = `Bool - let int : base = `Int - let nat : base = `Nat - - type 'a node = [ - | `Pair of 'a * 'a - | `Or of 'a * 'a - ] - - type expression_ast = [ - | expression node - | base - | `Name of name - ] - - and expression = expression_ast WrapLocation.t - - let pair ~loc a b : expression = wrap ~loc (`Pair(a,b)) - let union ~loc a b : expression = wrap ~loc (`Or(a,b)) - let name ~loc s : expression = - wrap ~loc (match s with - | "Unit" -> (unit :> expression_ast) - | "Bool" -> (bool :> expression_ast) - | "Int" -> (int :> expression_ast) - | "Nat" -> (nat :> expression_ast) - | s -> `Name s) - end - - module Value = struct - type name = string - type function_name = string - - type constant = [ - | `Int of int - ] - - type expression = [ - | `Variable of name - | `Pair of expression * expression - | `Application of expression * expression - | `Constant of constant - ] WrapLocation.t - - type assignment = [ - | `Let of name * expression - | `Type of Type.name * Type.expression - | `Function of function_name * Type.expression * block - ] WrapLocation.t - - and statement = [ - | `Assignment of assignment - | `ForEach of name * expression * block - | `While of expression * block - | `Condition of expression * block * (expression * block) list * block option - ] WrapLocation.t - - and block = statement list WrapLocation.t - - and program = assignment list WrapLocation.t - - type 'a wrapper = loc:Location.t -> 'a -> 'a WrapLocation.t - let int = (WrapLocation.make_f (fun a -> `Constant (`Int a)) : loc:_ -> _ -> expression) - let constatn = (WrapLocation.make_f (fun a -> `Constant a) : loc:_ -> _ -> expression) - - let variable = (WrapLocation.make_f (fun a -> `Variable a) : loc:_ -> _ -> expression) - - let pair = (WrapLocation.make_f (fun a -> `Pair a) : loc:_ -> _ -> expression) - let application = (WrapLocation.make_f (fun a -> `Application a) : loc:_ -> _ -> expression) - - let let_ = (WrapLocation.make_f (fun a -> `Let a) : loc:_ -> _ -> assignment) - let type_ = (WrapLocation.make_f (fun a -> `Type a) : loc:_ -> _ -> assignment) - let fun_ = (WrapLocation.make_f (fun a -> `Function a) : loc:_ -> _ -> assignment) - let assignment = (WrapLocation.make_f (fun a -> `Assignment a) : loc:_ -> _ -> statement) - - let foreach = (WrapLocation.make_f (fun a -> `ForEach a) : loc:_ -> _ -> statement) - let while_ = (WrapLocation.make_f (fun a -> `While a) : loc:_ -> _ -> statement) - - let elseif x : (expression * block) = x - let else_ x : block = x - let if_ = (WrapLocation.make_f (fun a -> `Condition a) : loc:_ -> _ -> statement) - - let block = (WrapLocation.make : loc:_ -> _ -> block) - let program = (WrapLocation.make : loc:_ -> _ -> program) - end -end - -module Typed = struct - - module Type = struct - module WrapLocation = Wrap.Location - let wrap = WrapLocation.make - - type name = string - - type base = [ - | `Unit - | `Bool - | `Int - | `Nat - ] - - let unit : base = `Unit - let bool : base = `Bool - let int : base = `Int - let nat : base = `Nat - - type 'a node = [ - | `Pair of 'a * 'a - | `Or of 'a * 'a - ] - - type value = [ - | value node - | base - ] - - type expression_ast = [ - | expression node - | base - | `Name of name - ] - - and expression = expression_ast - - let rec of_untyped (x:Untyped.Type.expression) : expression = match x.value with - | `Pair(a, b) -> `Pair(of_untyped a, of_untyped b) - | `Or(a, b) -> `Or(of_untyped a, of_untyped b) - | `Int as s -> s - | `Unit as s -> s - | `Nat as s -> s - | `Bool as s -> s - | `Name _ as s -> s - - let pair_v a b : value = `Pair(a,b) - let union_v a b : value = `Or(a,b) - - let pair_e a b : expression = `Pair(a,b) - let union_e a b : expression = `Or(a,b) - - let name : string -> expression = function - | "Unit" -> (unit :> expression_ast) - | "Bool" -> (bool :> expression_ast) - | "Int" -> (int :> expression_ast) - | "Nat" -> (nat :> expression_ast) - | s -> `Name s - - module Environment = Environment.Make(val ( - Environment.parameter () : - (module Environment.PARAMETER - with type key = name - and type value = value))) - - let rec eval (env:Environment.t) : expression -> value result = function - | `Name x -> ( - trace_option (simple_error "name doesn't exist in environment") @@ - Environment.get_opt env x - ) - | `Pair (a, b) -> ( - eval env a >>? fun a -> - eval env b >>? fun b -> - ok (`Pair (a, b)) - ) - | `Or (a, b) -> ( - eval env a >>? fun a -> - eval env b >>? fun b -> - ok (`Or (a, b)) - ) - | `Bool as x -> ok x - | `Unit as x -> ok x - | `Nat as x -> ok x - | `Int as x -> ok x - end - - module Value = struct - module WrapLocation = Wrap.Location - let wrap = WrapLocation.make - module WrapTypeLocation = Wrap.Make(struct type meta = (Type.value * Location.t) end) - let wrap_tl = WrapTypeLocation.make - let type_of (x:'a WrapTypeLocation.t) : Type.value = fst x.meta - - type name = string - type function_name = string - - type constant = [ - | `Int of int - ] - - type 'a node = [ - | `Constant of constant - | `Pair of 'a * 'a - ] - let int n = `Constant (`Int n) - - type value = value node - type expression = [ - | expression node - | `Variable of name - ] WrapTypeLocation.t - - let variable n = `Variable n - let pair a b = `Pair (a, b) - - type assignment = [ - | `Let of name * expression - | `Type of Type.name * Type.value - | `Function of function_name * Type.value * block * Type.value - ] WrapLocation.t - - and statement = assignment - - and block = statement list - - and toplevel_statement = assignment - - and program = toplevel_statement list - - module Environment = Environment.Make(val ( - Environment.parameter () : - (module Environment.PARAMETER - with type key = name - and type value = Type.value))) - end - - module Environment = struct - type type_environment = Type.Environment.t - type value_environment = Value.Environment.t - - type t = { - type_environment : type_environment ; - value_environment : value_environment ; - } - - let empty = { - type_environment = Type.Environment.empty ; - value_environment = Value.Environment.empty ; - } - - let add_type env - name type_value = - { env with - type_environment = - Type.Environment.set env.type_environment name type_value } - - let add_variable env - name type_value = - { env with - value_environment = - Value.Environment.set env.value_environment name type_value } - end - -end - - -module Typecheck = struct - module UV = Untyped.Value - module UT = Untyped.Type - module TV = Typed.Value - module TT = Typed.Type - - type env = Typed.Environment.t - type ty = Typed.Type.value - - let typecheck_constant (constant:UV.constant) : _ = match constant with - | `Int n -> (`Int, `Int n) - - let rec typecheck_expression (env:env) (e:UV.expression) : (TV.expression) result = - match e.value with - | `Constant c -> ( - let (ty, value) = typecheck_constant c in - ok (TV.wrap_tl (ty, e.meta) (`Constant value)) - ) - | `Variable n -> ( - trace_option (simple_error "variable doesn't exist in env") - @@ TV.Environment.get_opt env.value_environment n >>? fun ty -> - ok (TV.wrap_tl (ty, e.meta) (TV.variable n)) - ) - | `Pair(a, b) -> ( - typecheck_expression env a >>? fun a -> - typecheck_expression env b >>? fun b -> - let ty = TT.pair_v (TV.type_of a) (TV.type_of b) in - ok (TV.wrap_tl (ty, e.meta) (TV.pair a b)) - ) - | `Application _ -> simple_fail "Application isn't supported yet" - - let rec typecheck_assignment (env:env) (u:UV.assignment) : (env * TV.assignment) result = - match u.value with - | `Let(name, expression) -> ( - typecheck_expression env expression >>? fun expression -> - let ass : TV.assignment = TV.wrap ~loc:u.meta (`Let(name, expression)) in - let env = Typed.Environment.add_variable env name (TV.type_of expression) in - ok (env, ass) - ) - | `Type(name, expression) -> ( - TT.eval env.type_environment (TT.of_untyped expression) >>? fun value -> - let env = Typed.Environment.add_type env name value in - let ass : TV.assignment = TV.wrap ~loc:u.meta (`Type(name, value)) in - ok (env, ass) - ) - | `Function(name, type_expression, block) -> ( - TT.eval env.type_environment (TT.of_untyped type_expression) >>? fun type_value -> - let env = Typed.Environment.add_variable env "input" type_value in - typecheck_block env block >>? fun (env, block) -> - let ty = - match TV.Environment.get_opt env.value_environment "output" with - | None -> `Unit - | Some x -> x in - let ass : TV.assignment = TV.wrap ~loc:u.meta (`Function(name, type_value, block, ty)) in - ok (env, ass) - ) - - and typecheck_statement (env:env) (s:Untyped.Value.statement) : (env * Typed.Value.statement) result = - match s.value with - | `Assignment a -> typecheck_assignment env a - | `Condition (_bool_expr, _block, _elseifs, _else_opt) -> simple_fail "conditions aren't supported yet" - | `ForEach _ -> simple_fail "foreach is not supported yet" - | `While _ -> simple_fail "while is not supported yet" - - and typecheck_block (env:env) (b:Untyped.Value.block) : (env * Typed.Value.block) result = - let rec aux env = function - | [] -> ok (env, []) - | hd :: tl -> ( - typecheck_statement env hd >>? fun (env, hd) -> - aux env tl >>? fun (env, tl) -> - ok (env, hd :: tl) - ) in - aux env b.value - - let typecheck_program ?(env=Typed.Environment.empty) (u:Untyped.Value.program) : Typed.Value.program result = - let rec aux env = function - | [] -> ok [] - | hd :: tl -> ( - typecheck_assignment env hd >>? fun (env, hd) -> - aux env tl >>? fun tl -> - ok (hd :: tl) - ) in - aux env u.value -end - -module Transpile = struct - open Mini_c - open Typed - - let rec translate_type : Type.value -> Mini_c.type_value result = function - | `Bool -> ok (`Base Bool) - | `Int -> ok (`Base Int) - | `Nat -> ok (`Base Nat) - | `Unit -> ok (`Base Unit) - | `Pair(a, b) -> ( - translate_type a >>? fun a -> - translate_type b >>? fun b -> - ok (`Pair(a, b)) - ) - | `Or(a, b) -> ( - translate_type a >>? fun a -> - translate_type b >>? fun b -> - ok (`Or(a, b)) - ) - - let rec translate_expression (e:Value.expression) : Mini_c.expression result = - let%bind (e' : Mini_c.expression') = match e.value with - | `Constant (`Int n) -> ok (Literal (`Int n)) - | `Variable n -> ok (Var n) - | `Pair (a, b) -> ( - translate_expression a >>? fun a -> - translate_expression b >>? fun b -> - ok (Predicate("Pair", [a ; b])) - ) in - let%bind (t : Mini_c.type_value) = translate_type @@ fst e.meta in - ok (e', t) - - let rec translate_assignment (ass:Value.assignment) - : Mini_c.assignment option result = match ass.value with - | `Let(x, expr) -> ( - translate_expression expr >>? fun expr -> - ok (Some (Variable(x, expr))) - ) - | `Function(name, input_ty, body, output_ty) -> ( - translate_type input_ty >>? fun input -> - translate_type output_ty >>? fun output -> - block body >>? fun body -> - let ass = Fun(name, {input ; output ; body}) in - ok (Some ass) - ) - | `Type _ -> ok None - - and statement (st:Value.statement) - : Mini_c.statement option result = - translate_assignment st >>? fun a -> - let ass = match a with - | Some a -> Some (Assignment a) - | None -> None in - ok ass - - and block : Value.block -> Mini_c.block result = function - | [] -> ok [] - | hd :: tl -> ( - statement hd >>? fun st_opt -> - let sts = match st_opt with - | Some x -> [x] - | None -> [] in - block tl >>? fun (new_sts) -> - ok (sts @ new_sts) - ) - - let translate_toplevel_statement = translate_assignment - - let rec program : Value.program -> Mini_c.program result = function - | [] -> ok [] - | hd :: tl -> ( - translate_assignment hd >>? fun ass_opt -> - let asss = match ass_opt with - | Some x -> [x] - | None -> [] in - program tl >>? fun (new_asss) -> - ok (asss @ new_asss) - ) - - let of_mini_c : Mini_c.value -> Value.value result = function - | `Int n -> ok (Value.int n) - | _ -> simple_fail "unknown value" - - let to_mini_c : Value.value -> Mini_c.value result = function - | `Constant (`Int n) -> ok (`Int n) - | _ -> simple_fail "unknown value" - - let program_to_michelson (p:Value.program) = - let%bind program_mini_c = program p in - let%bind program = Mini_c.Translate_program.translate program_mini_c in - ok program.body -end - -module Run = struct - open Typed.Value - let run (program : program) (input : value) : value result = - Transpile.program program >>? fun program_mini_c -> - Transpile.to_mini_c input >>? fun input_mini_c -> - (* Format.printf "%a\n" Mini_c.PP.program program_mini_c ; *) - Mini_c.Run.run program_mini_c input_mini_c >>? fun output_mini_c -> - Transpile.of_mini_c output_mini_c >>? fun output -> - ok output -end diff --git a/src/ligo/mini_c.ml b/src/ligo/mini_c.ml index 3d075112e..ad1b17036 100644 --- a/src/ligo/mini_c.ml +++ b/src/ligo/mini_c.ml @@ -1042,14 +1042,16 @@ module Translate_AST = struct List.map (rename_declaration src dst) decls end + let list_of_map m = List.rev @@ SMap.fold (fun _ v prev -> v :: prev) m [] + let rec translate_type : AST.type_expr -> type_value result = fun {type_expr} -> match type_expr with | Unit -> ok (`Base Unit) | Int -> ok (`Base Int) | String -> ok (`Base String) | Bool -> ok (`Base Bool) - | Sum lst -> - let node = Append_tree.of_list @@ List.map snd lst in + | Sum m -> + let node = Append_tree.of_list @@ List.map snd @@ list_of_map m in let aux a b : type_value result = let%bind a = a in let%bind b = b in @@ -1057,7 +1059,7 @@ module Translate_AST = struct in Append_tree.fold_ne translate_type aux node | Record r -> - let node = Append_tree.of_list @@ List.map snd r in + let node = Append_tree.of_list @@ List.map snd @@ list_of_map r in let aux a b : type_value result = let%bind a = a in let%bind b = b in @@ -1150,8 +1152,8 @@ module Translate_AST = struct let rec to_mini_c_value' : (AST.expr_case * AST.type_expr) -> value result = function | Constant c, _ -> translate_constant c - | App {arguments;operator = {operator = Construcor c ; ty = {type_expr = Sum lst}}}, _ -> - let node = Append_tree.of_list @@ List.map fst lst in + | App {arguments;operator = {operator = Constructor c ; ty = {type_expr = Sum lst}}}, _ -> + let node = Append_tree.of_list @@ List.map fst @@ list_of_map lst in let%bind lst = trace_option (simple_error "Not constructor of variant type") @@ Append_tree.exists_path (fun (x:AST.name_and_region) -> x.name = c.name) node in diff --git a/src/ligo/parser.mly b/src/ligo/parser.mly deleted file mode 100644 index 91c5bf36e..000000000 --- a/src/ligo/parser.mly +++ /dev/null @@ -1,200 +0,0 @@ -%{ - module Location = Ligo_helpers.Location - open Main.Untyped - open Value -%} - -%token EOF -%token INT -//%token FLOAT -%token STRING -%token VAR_NAME -%token FUNCTION_NAME -%token TYPE_NAME -//%token PLUS MINUS TIMES DIV -%token COLON SEMICOLON /* DOUBLE_SEMICOLON */ COMMA AT EQUAL DOT -%token OR AND -%token LPAREN RPAREN -%token LBRACKET RBRACKET -%token IF ELSEIF ELSE // THEN -%token FOREACH OF WHILE -%token LET TYPE FUNCTION - - -// toto.tata @ 3 + 4 = 2 ; printf (lel) -//%left COLON -%left COMMA -%left AT -%left OR -%left AND -//%left EQUAL -//%left PLUS MINUS /* lowest precedence */ -//%left TIMES DIV /* medium precedence */ -%left DOT - -%start main - -%% - -main: - | sts = assignment+ EOF - { - let loc = Location.make $startpos $endpos in - program ~loc sts - } - -assignment: - | LET v = VAR_NAME EQUAL e = expr SEMICOLON - { - let loc = Location.make $startpos $endpos in - let_ ~loc (v, e) - } - | FUNCTION f = VAR_NAME COLON t = type_expr EQUAL b = block SEMICOLON - { - let loc = Location.make $startpos $endpos in - fun_ ~loc (f, t, b) - } - | TYPE n = TYPE_NAME EQUAL t = type_expr SEMICOLON - { - let loc = Location.make $startpos $endpos in - type_ ~loc (n, t) - } - -statement: - | ass = assignment - { - let loc = Location.make $startpos $endpos in - assignment ~loc ass - } - | FOREACH var = VAR_NAME OF iterator = expr body = block - { - let loc = Location.make $startpos $endpos in - foreach ~loc (var, iterator, body) - } - | WHILE cond = expr body = block - { - let loc = Location.make $startpos $endpos in - while_ ~loc (cond, body) - } - | IF e = expr b = block eis = else_if* eo = else_? - { - let loc = Location.make $startpos $endpos in - if_ ~loc (e, b, eis, eo) - } - -else_if: - | ELSEIF LPAREN cond = expr RPAREN body = block - { - elseif (cond, body) - } - -else_: - | ELSE body = block - { - else_ body - } - -block: - | LBRACKET sts = statement+ RBRACKET - { - let loc = Location.make $startpos $endpos in - block ~loc sts - } - -expr: - | i = INT - { - let loc = Location.make $startpos $endpos in - Value.int ~loc i - } -(* - | f = FLOAT - { - let loc = Location.make $startpos $endpos in - make ~loc @@ literal @@ Float f - } - | s = STRING - { - let loc = Location.make $startpos $endpos in - make ~loc @@ literal @@ String s - } -*) - | v = VAR_NAME - { - let loc = Location.make $startpos $endpos in - variable ~loc v - } - | LPAREN e = expr RPAREN - { - let loc = Location.make $startpos $endpos in - WrapLocation.update_location ~loc e - } - | e1 = expr COMMA e2 = expr - { - let loc = Location.make $startpos $endpos in - Value.pair ~loc (e1, e2) - } - | e1 = expr AT e2 = expr - { - let loc = Location.make $startpos $endpos in - application ~loc (e1, e2) - } - | e1 = expr DOT e2 = expr - { - let loc = Location.make $startpos $endpos in - application ~loc (e2, e1) - } -(* - | e = expr COLON t = type_expr - { - let loc = Location.make $startpos $endpos in - make ~loc @@ cast e t - } - | e1 = expr PLUS e2 = expr - { - let loc = Location.make $startpos $endpos in - make ~loc @@ primitive Plus [e1 ; e2] - } - | e1 = expr MINUS e2 = expr - { - let loc = Location.make $startpos $endpos in - make ~loc @@ primitive Minus [e1 ; e2] - } - | e1 = expr TIMES e2 = expr - { - let loc = Location.make $startpos $endpos in - make ~loc @@ primitive Times [e1 ; e2] - } - | e1 = expr DIV e2 = expr - { - let loc = Location.make $startpos $endpos in - make ~loc @@ primitive Div [e1 ; e2] - } - | e1 = expr EQUAL e2 = expr - { - let loc = Location.make $startpos $endpos in - make ~loc @@ primitive Equal [e1 ; e2] - } - | e = expr DOT v = VAR_NAME - { - let loc = Location.make $startpos $endpos in - make ~loc @@ dot e v - } -*) - -type_expr: - | t = TYPE_NAME - { - let loc = Location.make $startpos $endpos in - Type.(name ~loc t) - } - | t1 = type_expr AND t2 = type_expr - { - let loc = Location.make $startpos $endpos in - Type.(pair ~loc t1 t2) - } - | t1 = type_expr OR t2 = type_expr - { - let loc = Location.make $startpos $endpos in - Type.(union ~loc t1 t2) - } diff --git a/src/ligo/parser/ligo_parser.ml b/src/ligo/parser/ligo_parser.ml deleted file mode 100644 index 72c356b95..000000000 --- a/src/ligo/parser/ligo_parser.ml +++ /dev/null @@ -1 +0,0 @@ -module Typed = Typecheck2 diff --git a/src/ligo/test/test.ml b/src/ligo/test/test.ml index 3dc388f14..48a0304bb 100644 --- a/src/ligo/test/test.ml +++ b/src/ligo/test/test.ml @@ -8,175 +8,158 @@ let test name f = match f () with | Ok () -> () | Errors errs -> - Format.printf "Errors : {\n%a}\n%!" errors_pp errs ; - raise Alcotest.Test_error + Format.printf "Errors : {\n%a}\n%!" errors_pp errs ; + raise Alcotest.Test_error open Mini_c open Combinators -let simple_int_program body : program = [ - Fun("main", function_int body) -] +module Mini_c = struct -let run_int program n = - Run.run program (`Int n) >>? function - | `Int n -> ok n - | _ -> simple_fail "run_int : output not int" - -let neg () = - let program : program = simple_int_program [ - assign_variable "output" @@ neg_int (var_int "input") ; - assign_variable "output" @@ neg_int (var_int "output") ; - assign_variable "output" @@ neg_int (var_int "output") ; - ] in - run_int program 42 >>? fun output -> - Assert.assert_equal_int (-42) output >>? fun () -> - ok () - -let multiple_variables () = - let program = simple_int_program [ - assign_variable "a" @@ neg_int (var_int "input") ; - assign_variable "b" @@ neg_int (var_int "a") ; - assign_variable "c" @@ neg_int (var_int "b") ; - assign_variable "d" @@ neg_int (var_int "c") ; - assign_variable "output" @@ neg_int (var_int "d") ; - ] in - run_int program 42 >>? fun output -> - Assert.assert_equal_int (-42) output >>? fun () -> - ok () - -let arithmetic () = - let expression = add_int (var_int "input") (neg_int (var_int "input")) in - let program = simple_int_program [ - Assignment (Variable ("a", expression)) ; - Assignment (Variable ("b", var_int "a")) ; - Assignment (Variable ("output", var_int "b")) ; - ] in - let test n = - run_int program n >>? fun output -> - Assert.assert_equal_int 0 output >>? fun () -> - ok () - in - let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in - ok () - -let quote_ () = - let program = simple_int_program [ - assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (int 42)] ; - assign_function "g" @@ function_int [assign_variable "output" @@ neg_int (var_int "input")] ; - assign_variable "output" @@ apply_int (type_f_int @@ var "g") @@ apply_int (type_f_int @@ var "f") (var_int "input") ; - ] in - let%bind output = run_int program 42 in - let%bind _ = Assert.assert_equal_int (-84) output in - ok () - -let function_ () = - let program = simple_int_program [ - assign_variable "a" @@ int 42 ; - assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (var_int "a")] ; - let env = Environment.Small.of_list ["a", t_int] in - assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ; - ] in - let%bind output = run_int program 100 in - let%bind _ = Assert.assert_equal_int 142 output in - ok () - -let functions_ () = - let program = simple_int_program [ - assign_variable "a" @@ int 42 ; - assign_variable "b" @@ int 144 ; - assign_function "f" @@ function_int [ - assign_variable "output" @@ add_int (var_int "input") (var_int "a") - ] ; - assign_function "g" @@ function_int [ - assign_variable "output" @@ add_int (var_int "input") (var_int "b") - ] ; - let env_f = Environment.Small.of_list ["a", t_int] in - let env_g = Environment.Small.of_list ["b", t_int] in - assign_variable "output" @@ add_int - (apply_int (type_closure_int env_f @@ var "f") (var_int "input")) - (apply_int (type_closure_int env_g @@ var "g") (var_int "input")) - ] in - let%bind output = run_int program 100 in - let%bind _ = Assert.assert_equal_int 386 output in - ok () - -let rich_function () = - let program = simple_int_program [ - assign_variable "a" @@ int 42 ; - assign_variable "b" @@ int 144 ; - assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "a") (var_int "b")] ; - let env = Environment.Small.of_list [("a", t_int) ; ("b", t_int)] in - assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ; - ] in - let test n = - let%bind output = run_int program n in - let%bind _ = Assert.assert_equal_int 186 output in - ok () in - let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in - ok () - -let main = "Mini_c", [ - test "basic.neg" neg ; - test "basic.variables" multiple_variables ; - test "basic.arithmetic" arithmetic ; - test "basic.quote" quote_ ; - test "basic.function" function_ ; - test "basic.functions" functions_ ; - test "basic.rich_function" rich_function ; + let simple_int_program body : program = [ + Fun("main", function_int body) ] -(* module Ligo = struct - * let parse_file (source:string) : Ligo.Untyped.Value.program result = - * let channel = open_in source in - * let lexbuf = Lexing.from_channel channel in - * specific_try (function - * | Parser.Error -> ( - * let start = Lexing.lexeme_start_p lexbuf in - * let end_ = Lexing.lexeme_end_p lexbuf in - * let str = Format.sprintf - * "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - * (Lexing.lexeme lexbuf) - * start.pos_lnum (start.pos_cnum - start.pos_bol) - * end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - * simple_error str - * ) - * | Lexer.Unexpected_character s -> simple_error s - * | Lexer.Error _ -> simple_error "lexer error" - * | _ -> simple_error "unrecognized parse_ error" - * ) @@ (fun () -> Parser.main Lexer.token lexbuf) >>? fun program_ast -> - * ok program_ast - * - * let run (source:string) (input:Ligo.Typed.Value.value) : Ligo.Typed.Value.value result = - * parse_file source >>? fun program_ast -> - * Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program -> - * Ligo.Run.run typed_program input >>? fun output -> - * ok output - * - * let assert_value_int : Ligo.Typed.Value.value -> int result = function - * | `Constant (`Int n) -> ok n - * | _ -> simple_fail "not an int" - * - * let basic () : unit result = - * run "./contracts/toto.ligo" (Ligo.Typed.Value.int 42) >>? fun output -> - * assert_value_int output >>? fun output -> - * Assert.assert_equal_int 42 output >>? fun () -> - * ok () - * - * let display_basic () : unit result = - * parse_file "./contracts/toto.ligo" >>? fun program_ast -> - * Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program -> - * Ligo.Transpile.program_to_michelson typed_program >>? fun node -> - * let node = Tezos_utils.Cast.flatten_node node in - * let str = Tezos_utils.Cast.node_to_string node in - * Format.printf "Program:\n%s\n%!" str ; - * ok () - * - * let main = "Ligo", [ - * test "basic" basic ; - * test "basic.display" display_basic ; - * ] - * end *) + let run_int program n = + Run.run program (`Int n) >>? function + | `Int n -> ok n + | _ -> simple_fail "run_int : output not int" + + let neg () = + let program : program = simple_int_program [ + assign_variable "output" @@ neg_int (var_int "input") ; + assign_variable "output" @@ neg_int (var_int "output") ; + assign_variable "output" @@ neg_int (var_int "output") ; + ] in + run_int program 42 >>? fun output -> + Assert.assert_equal_int (-42) output >>? fun () -> + ok () + + let multiple_variables () = + let program = simple_int_program [ + assign_variable "a" @@ neg_int (var_int "input") ; + assign_variable "b" @@ neg_int (var_int "a") ; + assign_variable "c" @@ neg_int (var_int "b") ; + assign_variable "d" @@ neg_int (var_int "c") ; + assign_variable "output" @@ neg_int (var_int "d") ; + ] in + run_int program 42 >>? fun output -> + Assert.assert_equal_int (-42) output >>? fun () -> + ok () + + let arithmetic () = + let expression = add_int (var_int "input") (neg_int (var_int "input")) in + let program = simple_int_program [ + Assignment (Variable ("a", expression)) ; + Assignment (Variable ("b", var_int "a")) ; + Assignment (Variable ("output", var_int "b")) ; + ] in + let test n = + run_int program n >>? fun output -> + Assert.assert_equal_int 0 output >>? fun () -> + ok () + in + let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in + ok () + + let quote_ () = + let program = simple_int_program [ + assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (int 42)] ; + assign_function "g" @@ function_int [assign_variable "output" @@ neg_int (var_int "input")] ; + assign_variable "output" @@ apply_int (type_f_int @@ var "g") @@ apply_int (type_f_int @@ var "f") (var_int "input") ; + ] in + let%bind output = run_int program 42 in + let%bind _ = Assert.assert_equal_int (-84) output in + ok () + + let function_ () = + let program = simple_int_program [ + assign_variable "a" @@ int 42 ; + assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (var_int "a")] ; + let env = Environment.Small.of_list ["a", t_int] in + assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ; + ] in + let%bind output = run_int program 100 in + let%bind _ = Assert.assert_equal_int 142 output in + ok () + + let functions_ () = + let program = simple_int_program [ + assign_variable "a" @@ int 42 ; + assign_variable "b" @@ int 144 ; + assign_function "f" @@ function_int [ + assign_variable "output" @@ add_int (var_int "input") (var_int "a") + ] ; + assign_function "g" @@ function_int [ + assign_variable "output" @@ add_int (var_int "input") (var_int "b") + ] ; + let env_f = Environment.Small.of_list ["a", t_int] in + let env_g = Environment.Small.of_list ["b", t_int] in + assign_variable "output" @@ add_int + (apply_int (type_closure_int env_f @@ var "f") (var_int "input")) + (apply_int (type_closure_int env_g @@ var "g") (var_int "input")) + ] in + let%bind output = run_int program 100 in + let%bind _ = Assert.assert_equal_int 386 output in + ok () + + let rich_function () = + let program = simple_int_program [ + assign_variable "a" @@ int 42 ; + assign_variable "b" @@ int 144 ; + assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "a") (var_int "b")] ; + let env = Environment.Small.of_list [("a", t_int) ; ("b", t_int)] in + assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ; + ] in + let test n = + let%bind output = run_int program n in + let%bind _ = Assert.assert_equal_int 186 output in + ok () in + let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in + ok () + + let main = "Mini_c", [ + test "basic.neg" neg ; + test "basic.variables" multiple_variables ; + test "basic.arithmetic" arithmetic ; + test "basic.quote" quote_ ; + test "basic.function" function_ ; + test "basic.functions" functions_ ; + test "basic.rich_function" rich_function ; + ] +end + +module Ligo = struct + let run (source:string) (input:Ligo.Typed.O.value) : Ligo.Typed.Value.value result = + parse_file source >>? fun program_ast -> + Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program -> + Ligo.Run.run typed_program input >>? fun output -> + ok output + + let assert_value_int : Ligo.Typed.Value.value -> int result = function + | `Constant (`Int n) -> ok n + | _ -> simple_fail "not an int" + + let basic () : unit result = + run "./contracts/toto.ligo" (Ligo.Typed.Value.int 42) >>? fun output -> + assert_value_int output >>? fun output -> + Assert.assert_equal_int 42 output >>? fun () -> + ok () + + let display_basic () : unit result = + parse_file "./contracts/toto.ligo" >>? fun program_ast -> + Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program -> + Ligo.Transpile.program_to_michelson typed_program >>? fun node -> + let node = Tezos_utils.Cast.flatten_node node in + let str = Tezos_utils.Cast.node_to_string node in + Format.printf "Program:\n%s\n%!" str ; + ok () + + let main = "Ligo", [ + test "basic" basic ; + test "basic.display" display_basic ; + ] +end let () = (* Printexc.record_backtrace true ; *) diff --git a/src/ligo/type_ast.ml b/src/ligo/type_ast.ml new file mode 100644 index 000000000..82f4bd471 --- /dev/null +++ b/src/ligo/type_ast.ml @@ -0,0 +1,138 @@ +open Ligo_helpers.Trace + +module I = Ast_simplified +module O = Ast_typed + +module SMap = O.SMap + +module Environment = struct + type t = unit + let empty : t = () + + let get (():t) (_s:string) : O.type_value option = None + let add (():t) (_s:string) (_tv:O.type_value) : t = () + let get_type (():t) (_s:string) : O.type_value option = None + let add_type (():t) (_s:string) (_tv:O.type_value) : t = () +end + +type environment = Environment.t + +type environment = unit +let empty : environment = () + +let rec type_program (p:I.program) : O.program result = + let aux (e, acc:(environment * O.declaration list)) (d:I.declaration) = + let%bind (e', d') = type_declaration e d in + match d' with + | None -> ok (e', acc) + | Some d' -> ok (e', d' :: acc) + in + let%bind (_, lst) = bind_fold_list aux (empty, []) p in + ok @@ List.rev lst + +and type_declaration _env : I.declaration -> (environment * O.declaration option) result = function + | Type_declaration _ -> simple_fail "" + | Constant_declaration _ -> simple_fail "" + +and type_block (e:environment) (b:I.block) : O.block result = + let aux (e, acc:(environment * O.instruction list)) (i:I.instruction) = + let%bind (e', i') = type_instruction e i in + ok (e', i' :: acc) + in + let%bind (_, lst) = bind_fold_list aux (e, []) b in + ok @@ List.rev lst + +and type_instruction (e:environment) : I.instruction -> (environment * O.instruction) result = function + | Skip -> ok (e, O.Skip) + | Fail x -> + let%bind expression = type_annotated_expression e x in + ok (e, O.Fail expression) + | Loop (cond, body) -> + let%bind cond = type_annotated_expression e cond in + let%bind _ = + O.type_value_eq (cond.type_annotation, (O.Type_constant ("bool", []))) in + let%bind body = type_block e body in + ok (e, O.Loop (cond, body)) + | Assignment {name;annotated_expression} -> ( + match annotated_expression.type_annotation, Environment.get e name with + | None, None -> simple_fail "Initial assignments need type" + | Some _, None -> + let%bind annotated_expression = type_annotated_expression e annotated_expression in + let e' = Environment.add e name annotated_expression.type_annotation in + ok (e', O.Assignment {name;annotated_expression}) + | None, Some prev -> + let%bind annotated_expression = type_annotated_expression e annotated_expression in + let e' = Environment.add e name annotated_expression.type_annotation in + let%bind _ = + O.type_value_eq (annotated_expression.type_annotation, prev) in + ok (e', O.Assignment {name;annotated_expression}) + | Some _, Some prev -> + let%bind annotated_expression = type_annotated_expression e annotated_expression in + let%bind _assert = trace (simple_error "Annotation doesn't match environment") + @@ O.type_value_eq (annotated_expression.type_annotation, prev) in + let e' = Environment.add e name annotated_expression.type_annotation in + ok (e', O.Assignment {name;annotated_expression}) + ) + | Matching m -> + let%bind m' = type_match e m in + ok (e, O.Matching m') + +and type_match (e:environment) : I.matching -> O.matching result = function + | Match_bool {match_true ; match_false} -> + let%bind match_true = type_block e match_true in + let%bind match_false = type_block e match_false in + ok (O.Match_bool {match_true ; match_false}) + | Match_option {match_none ; match_some} -> + let%bind match_none = type_block e match_none in + let (n, b) = match_some in + let%bind b' = type_block e b in + ok (O.Match_option {match_none ; match_some = (n, b')}) + | Match_list {match_nil ; match_cons} -> + let%bind match_nil = type_block e match_nil in + let (n, m, b) = match_cons in + let%bind b' = type_block e b in + ok (O.Match_list {match_nil ; match_cons = (n, m, b')}) + | Match_tuple lst -> + let aux (x, y) = + let%bind y = type_block e y in + ok (x, y) in + let%bind lst' = bind_list @@ List.map aux lst in + ok (O.Match_tuple lst') + +and evaluate_type (e:environment) : I.type_expression -> O.type_value result = function + | Type_tuple lst -> + let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in + ok (O.Type_tuple lst') + | Type_sum m -> + let aux k v prev = + let%bind prev' = prev in + let%bind v' = evaluate_type e v in + ok @@ SMap.add k v' prev' + in + let%bind m = SMap.fold aux m (ok SMap.empty) in + ok (O.Type_sum m) + | Type_record m -> + let aux k v prev = + let%bind prev' = prev in + let%bind v' = evaluate_type e v in + ok @@ SMap.add k v' prev' + in + let%bind m = SMap.fold aux m (ok SMap.empty) in + ok (O.Type_record m) + | Type_variable name -> + let%bind tv = + trace_option (simple_error "unbound type variable") + @@ Environment.get_type e name in + ok tv + | Type_constant (cst, lst) -> + let%bind lst' = bind_list @@ List.map (evaluate_type e) lst in + ok (O.Type_constant(cst, lst')) + +and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.annotated_expression result = + match ae.expression with + | Variable name -> + let%bind tv' = + trace_option (simple_error "var not in env") + @@ Environment.get e name in + ok O.{expression = Variable name ; type_annotation = tv'} + | _ -> simple_fail "default"