tmp

.gitignore

@@ -6,6 +6,7 @@ __pycache__
 *.pyc
 
 /_build
+*/_build
 /_opam
 /_docker_build
 /docs/_build

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

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)

src/ligo/bin/cli.ml

@@ -1 +1 @@
-let () = print_int 42
+let () = ()

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 ))
 )

src/ligo/lexer.mll

@@ -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))) }

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

src/ligo/ligo-helpers/x_map.ml

@@ -0,0 +1 @@
+module String = Map.Make(String)

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
+  | PRecord of (field_name * pattern) SMap.t
-
-  and 'key precord = ('key * pattern) list
 
   type type_constructor =
     Option
@@ -40,8 +36,8 @@ module O = struct
   | Map
 
   type type_expr_case =
-    Sum      of (type_name * type_expr) list
+    Sum      of (type_name * type_expr) SMap.t
-  | Record   of record_key type_record
+  | 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 }
@@ -74,32 +70,35 @@ module O = struct
 
   and operator =
     Function    of var_name
-    | Construcor  of var_name
+  | Constructor of var_name
-    | UpdateField of record_key
+  | UpdateField of field_name
-    | GetField    of record_key
+  | GetField    of field_name
   | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
   | Neg | Not
-    | Tuple | Set | List
+  | Set | List
   | MapLookup
 
   and constant =
-    Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True
+    Unit
-    | Null of type_expr | EmptySet of type_expr | CNone of type_expr
+  | 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 }
+    Assignment    of { name: var_name; value: expr; orig: asttodo }
-  | While         of { condition: expr; body: instr list }
+  | While         of { condition: expr; body: instr list; orig: asttodo }
-  | ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list }
+  | ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo }
-  | If            of { condition: expr; ifso: instr list; ifnot: instr list }
+  | Match         of { expr: expr; cases: (pattern * instr list) list; orig: asttodo }
-  | Match         of { expr: expr; cases: (pattern * instr list) list }
+  | ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *)
-  | DropUnit      of expr       (* expr returns unit, drop the result. *)
+  | Fail          of { expr: expr; orig: asttodo }
-  | Fail          of { expr: expr }
 
   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)
+  |> mapi (fun i p -> name_and_region_of_int i, p)
-  |> fun x -> O.PRecord x
+  |> 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,7 +447,7 @@ 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;
@@ -433,20 +455,26 @@ and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : I.fo
           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
-  [
+  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;
-        key = s_name var;
+           var = s_name var;
-        value = s_bind_to bind_to;
+           body = s_block block;
-        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,6 +490,12 @@ and s_loop : I.loop -> O.instr list = function
 
 and s_fun_call {value=(fun_name, arguments); region} : O.expr =
   let () = ignore (region) in
+  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 =
@@ -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
+  let () = match operations_decl with
-      Some x -> x
+      Some _ -> failwith "Operations declaration is not allowed anymore TODO"
-    | None -> failwith "Missing storage declaration"
+    | None -> ()
-  in {types; storage_decl; operations_decl; declarations}
+  in {types; storage_decl; declarations; orig = ast}
 
 
 

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
+  if false then
-  let _ = temporary_force_dune in
+    let _ = Typecheck2.annotate in
+    ()
+  else
     ()

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
+    Sum      of (type_name * type_expr) SMap.t
-  | Record   of (field_name * type_expr) list
+  | 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
@@ -102,4 +106,57 @@ module O = struct
     }
 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
+

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
+    Sum      of (type_name * type_expr) SMap.t
-  | Record   of (field_name * type_expr) list
+  | 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
@@ -102,4 +104,4 @@ module O : sig
     }
 end
 
-val temporary_force_dune : int
+val annotate : I.ast -> O.ast

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

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

src/ligo/main.ml

@@ -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

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 ->
+    | Sum m ->
-       let node = Append_tree.of_list @@ List.map snd lst in
+       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}}}, _ ->
+    | App {arguments;operator = {operator = Constructor c ; ty = {type_expr = Sum lst}}}, _ ->
-       let node = Append_tree.of_list @@ List.map fst lst in
+       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

src/ligo/parser.mly

@@ -1,200 +0,0 @@
-%{
-    module Location = Ligo_helpers.Location
-    open Main.Untyped
-    open Value
-%}
-
-%token EOF
-%token <int> INT
-//%token <float> FLOAT
-%token <string> STRING
-%token <string> VAR_NAME
-%token <string> FUNCTION_NAME
-%token <string> 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.Untyped.Value.program> 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)
-    }

src/ligo/parser/ligo_parser.ml

@@ -1 +0,0 @@
-module Typed = Typecheck2

src/ligo/test/test.ml

@@ -14,6 +14,8 @@ let test name f =
 open Mini_c
 open Combinators
 
+module Mini_c = struct
+
   let simple_int_program body : program = [
     Fun("main", function_int body)
   ]
@@ -125,58 +127,39 @@ let main = "Mini_c", [
       test "basic.functions" functions_ ;
       test "basic.rich_function" rich_function ;
     ]
+end
 
-(* module Ligo = struct
+module Ligo = struct
- *   let parse_file (source:string) : Ligo.Untyped.Value.program result =
+  let run (source:string) (input:Ligo.Typed.O.value) : Ligo.Typed.Value.value result =
- *     let channel = open_in source in
+    parse_file source >>? fun program_ast ->
- *     let lexbuf = Lexing.from_channel channel in
+    Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
- *     specific_try (function
+    Ligo.Run.run typed_program input >>? fun output ->
- *         | Parser.Error -> (
+    ok output
- *             let start = Lexing.lexeme_start_p lexbuf in
+
- *             let end_ = Lexing.lexeme_end_p lexbuf in
+  let assert_value_int : Ligo.Typed.Value.value -> int result = function
- *             let str = Format.sprintf
+    | `Constant (`Int n) -> ok n
- *                 "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
+    | _ -> simple_fail "not an int"
- *                 (Lexing.lexeme lexbuf)
+
- *                 start.pos_lnum (start.pos_cnum - start.pos_bol)
+  let basic () : unit result =
- *                 end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
+    run "./contracts/toto.ligo" (Ligo.Typed.Value.int 42) >>? fun output ->
- *             simple_error str
+    assert_value_int output >>? fun output ->
- *           )
+    Assert.assert_equal_int 42 output >>? fun () ->
- *         | Lexer.Unexpected_character s -> simple_error s
+    ok ()
- *         | Lexer.Error _ -> simple_error "lexer error"
+
- *         | _ -> simple_error "unrecognized parse_ error"
+  let display_basic () : unit result =
- *       ) @@ (fun () -> Parser.main Lexer.token lexbuf) >>? fun program_ast ->
+    parse_file "./contracts/toto.ligo" >>? fun program_ast ->
- *     ok program_ast
+    Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
- *
+    Ligo.Transpile.program_to_michelson typed_program >>? fun node ->
- *   let run (source:string) (input:Ligo.Typed.Value.value) : Ligo.Typed.Value.value result =
+    let node = Tezos_utils.Cast.flatten_node node in
- *     parse_file source >>? fun program_ast ->
+    let str = Tezos_utils.Cast.node_to_string node in
- *     Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
+    Format.printf "Program:\n%s\n%!" str ;
- *     Ligo.Run.run typed_program input >>? fun output ->
+    ok ()
- *     ok output
+
- *
+  let main = "Ligo", [
- *   let assert_value_int : Ligo.Typed.Value.value -> int result = function
+      test "basic" basic ;
- *     | `Constant (`Int n) -> ok n
+      test "basic.display" display_basic ;
- *     | _ -> simple_fail "not an int"
+    ]
- *
+end
- *   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 ; *)

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"