first working example of the whole pipeline

.gitignore

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

src/ligo/ast_simplified.ml

@@ -81,6 +81,7 @@ and instruction =
   | Loop of ae * b
   | Skip
   | Fail of ae
+  | Record_patch of ae * (string * ae) list
 
 and matching =
   | Match_bool of {
@@ -106,22 +107,38 @@ module Simplify = struct
 
   let nseq_to_list (hd, tl) = hd :: tl
   let npseq_to_list (hd, tl) = hd :: (List.map snd tl)
+  let npseq_to_nelist (hd, tl) = hd, (List.map snd tl)
+  let pseq_to_list = function
+    | None -> []
+    | Some lst -> npseq_to_list lst
+
+  let type_constants = [
+    ("nat", 0) ;
+    ("int", 0) ;
+  ]
 
   let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
     match t with
     | TPar x -> simpl_type_expression x.value.inside
-    | TAlias v -> ok @@ Type_variable v.value
+    | TAlias v -> (
+        match List.assoc_opt v.value type_constants with
+        | Some 0 -> ok @@ Type_constant (v.value, [])
+        | Some _ -> simple_fail "type constructor with wrong number of args"
+        | None -> ok @@ Type_variable v.value
+      )
     | TApp x ->
         let (name, tuple) = x.value in
-        let%bind lst = bind_list
+        let lst = npseq_to_list tuple.value.inside in
-          @@ List.map simpl_type_expression
+        let%bind _ = match List.assoc_opt name.value type_constants with
-          @@ npseq_to_list tuple.value.inside in
+        | Some n when n = List.length lst -> ok ()
-        ok @@ Type_constant (name.value, lst)
+        | Some _ -> simple_fail "type constructor with wrong number of args"
+        | None -> simple_fail "unrecognized type constants" in
+        let%bind lst' = bind_list @@ List.map simpl_type_expression lst in
+        ok @@ Type_constant (name.value, lst')
     | TProd p ->
-        let%bind lst = bind_list
+        let%bind tpl = simpl_list_type_expression
-          @@ List.map simpl_type_expression
           @@ npseq_to_list p.value in
-        ok @@ Type_tuple lst
+        ok tpl
     | TRecord r ->
         let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in
         let%bind lst = bind_list
@@ -161,16 +178,32 @@ module Simplify = struct
         ok @@ ae @@ Application (ae @@ Variable f, arg)
     | EPar x -> simpl_expression x.value.inside
     | EUnit _ -> ok @@ ae @@ Literal Unit
-    | EBytes x -> ok @@ ae @@ Literal (Bytes (fst x.value))
+    | EBytes x -> ok @@ ae @@ Literal (Bytes (Bytes.of_string @@ fst x.value))
     | ETuple tpl ->
         simpl_list_expression
         @@ npseq_to_list tpl.value.inside
+    | ERecord (RecordInj r) ->
+        let%bind fields = bind_list
+          @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v))
+          @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
+          @@ npseq_to_list r.value.fields in
+        let aux prev (k, v) = SMap.add k v prev in
+        ok @@ ae @@ Record (List.fold_left aux SMap.empty fields)
+    | ERecord (RecordProj p) ->
+        let record = p.value.record_name.value in
+        let lst = List.map (fun (x:_ Raw.reg) -> x.value) @@ npseq_to_list p.value.field_path in
+        let aux prev cur =
+          ae @@ Record_accessor (prev, cur)
+        in
+        let init = ae @@ Variable record in
+        ok @@ List.fold_left aux init lst
     | EConstr (ConstrApp c) ->
         let (c, args) = c.value in
         let%bind arg =
           simpl_list_expression
           @@ npseq_to_list args.value.inside in
         ok @@ ae @@ Constructor (c.value, arg)
+    | EConstr _ -> simple_fail "econstr: not supported yet"
     | EArith (Add c) ->
         let%bind (a, b) = simpl_binop c.value in
         ok @@ ae @@ Constant ("ADD", [a;b])
@@ -181,7 +214,15 @@ module Simplify = struct
     | EString (String s) ->
         ok @@ ae @@ Literal (String s.value)
     | EString _ -> simple_fail "string: not supported yet"
-    | _ -> simple_fail "todo"
+    | ELogic (BoolExpr (False _)) ->
+        ok @@ ae @@ Literal (Bool false)
+    | ELogic (BoolExpr (True _)) ->
+        ok @@ ae @@ Literal (Bool true)
+    | ELogic _ -> simple_fail "logic: not supported yet"
+    | EList _ -> simple_fail "list: not supported yet"
+    | ESet _ -> simple_fail "set: not supported yet"
+    | EMap _ -> simple_fail "map: not supported yet"
+
 
   and simpl_binop (t:_ Raw.bin_op) : (ae * ae) result =
     let%bind a = simpl_expression t.arg1 in
@@ -196,7 +237,36 @@ module Simplify = struct
         let%bind lst = bind_list @@ List.map simpl_expression lst in
         ok @@ ae @@ Tuple lst
 
-  and simpl_lambda (t:Raw.lambda_decl) : lambda result = simple_fail "todo"
+  and simpl_local_declaration (t:Raw.local_decl) : instruction result =
+    match t with
+    | LocalVar x ->
+        let x = x.value in
+        let name = x.name.value in
+        let%bind t = simpl_type_expression x.var_type in
+        let type_annotation = Some t in
+        let%bind expression = simpl_expression x.init in
+        ok @@ Assignment {name;annotated_expression={expression with type_annotation}}
+    | LocalConst x ->
+        let x = x.value in
+        let name = x.name.value in
+        let%bind t = simpl_type_expression x.const_type in
+        let type_annotation = Some t in
+        let%bind expression = simpl_expression x.init in
+        ok @@ Assignment {name;annotated_expression={expression with type_annotation}}
+    | _ -> simple_fail "todo"
+
+  and simpl_param (t:Raw.param_decl) : named_type_expression result =
+    match t with
+    | ParamConst c ->
+        let c = c.value in
+        let type_name = c.var.value in
+        let%bind type_expression = simpl_type_expression c.param_type in
+        ok { type_name ; type_expression }
+    | ParamVar v ->
+        let c = v.value in
+        let type_name = c.var.value in
+        let%bind type_expression = simpl_type_expression c.param_type in
+        ok { type_name ; type_expression }
 
   and simpl_declaration (t:Raw.declaration) : declaration result =
     let open! Raw in
@@ -213,8 +283,130 @@ module Simplify = struct
         ok @@ Constant_declaration {name=name.value;annotated_expression={expression with type_annotation}}
     | LambdaDecl (FunDecl x) ->
         let {name;param;ret_type;local_decls;block;return} : fun_decl = x.value in
-        simple_fail "todo"
+        let%bind param = match npseq_to_list param.value.inside with
-    | _ -> simple_fail "todo"
+          | [a] -> ok a
+          | _ -> simple_fail "only one param allowed" in
+        let%bind input = simpl_param param in
+        let name = name.value in
+        let binder = input.type_name in
+        let input_type = input.type_expression in
+        let%bind local_declarations = bind_list @@ List.map simpl_local_declaration local_decls in
+        let%bind instructions = bind_list
+          @@ List.map simpl_instruction
+          @@ npseq_to_list block.value.instr in
+        let%bind result = simpl_expression return in
+        let%bind output_type = simpl_type_expression ret_type in
+        let body = local_declarations @ instructions in
+        let expression = Lambda {binder ; input_type ; output_type ; result ; body } in
+        let type_annotation = Some (Type_function (input_type, output_type)) in
+        ok @@ Constant_declaration {name;annotated_expression = {expression;type_annotation}}
+    | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet"
+    | LambdaDecl (EntryDecl _)-> simple_fail "no entry point yet"
+
+
+  and simpl_single_instruction (t:Raw.single_instr) : instruction result =
+    match t with
+    | ProcCall _ -> simple_fail "no proc call"
+    | Fail e ->
+        let%bind expr = simpl_expression e.value.fail_expr in
+        ok @@ Fail expr
+    | Skip _ -> ok @@ Skip
+    | Loop (While l) ->
+        let l = l.value in
+        let%bind cond = simpl_expression l.cond in
+        let%bind body = simpl_block l.block.value in
+        ok @@ Loop (cond, body)
+    | Loop (For _) ->
+        simple_fail "no for yet"
+    | Cond c ->
+        let c = c.value in
+        let%bind expr = simpl_expression c.test in
+        let%bind match_true = simpl_instruction_block c.ifso in
+        let%bind match_false = simpl_instruction_block c.ifnot in
+        ok @@ Matching (expr, (Match_bool {match_true; match_false}))
+    | Assign a ->
+        let a = a.value in
+        let%bind name = match a.lhs with
+          | Path (Name v) -> ok v.value
+          | _ -> simple_fail "no complex assignments yet"
+        in
+        let%bind annotated_expression = match a.rhs with
+          | Expr e -> simpl_expression e
+          | _ -> simple_fail "no weird assignments yet"
+        in
+        ok @@ Assignment {name ; annotated_expression}
+    | Case c ->
+        let c = c.value in
+        let%bind expr = simpl_expression c.expr in
+        let%bind cases = bind_list
+          @@ List.map (fun (x:Raw.case) -> let%bind i = simpl_instruction_block x.instr in ok (x.pattern, i))
+          @@ List.map (fun (x:_ Raw.reg) -> x.value)
+          @@ npseq_to_list c.cases.value in
+        let%bind m = simpl_cases cases in
+        ok @@ Matching (expr, m)
+    | RecordPatch r ->
+        let r = r.value in
+        let%bind record = match r.path with
+          | Name v -> ok v.value
+          | _ -> simple_fail "no complex assignments yet"
+        in
+        let%bind inj = bind_list
+          @@ List.map (fun (x:Raw.field_assign) -> let%bind e = simpl_expression x.field_expr in ok (x.field_name.value, e))
+          @@ List.map (fun (x:_ Raw.reg) -> x.value)
+          @@ npseq_to_list r.record_inj.value.fields in
+        ok @@ Record_patch ({expression=Variable record;type_annotation=None}, inj)
+    | MapPatch _ -> simple_fail "no map patch yet"
+
+  and simpl_cases (t:(Raw.pattern * block) list) : matching result =
+    let open Raw in
+    let get_var (t:Raw.pattern) = match t with
+      | PVar v -> ok v.value
+      | _ -> simple_fail "not a var"
+    in
+    match t with
+    | [(PFalse _, f) ; (PTrue _, t)]
+    | [(PTrue _, f) ; (PFalse _, t)] -> ok @@ Match_bool {match_true = t ; match_false = f}
+    | [(PSome v, some) ; (PNone _, none)]
+    | [(PNone _, none) ; (PSome v, some)] -> (
+        let (_, v) = v.value in
+        let%bind v = match v.value.inside with
+        | PVar v -> ok v.value
+        | _ -> simple_fail "complex patterns not supported yet" in
+        ok @@ Match_option {match_none = none ; match_some = (v, some) }
+      )
+    | [(PCons c, cons) ; (PList n, nil)]
+    | [(PList n, nil) ; (PCons c, cons)] ->
+        let%bind _ = match n with
+          | Sugar c -> (
+              match pseq_to_list c.value.inside with
+              | [] -> ok ()
+              | _ -> simple_fail "complex patterns not supported yet"
+            )
+          | Raw _ -> simple_fail "complex patterns not supported yet"
+        in
+        let%bind (a, b) =
+          match c.value with
+          | a, [(_, b)] ->
+              let%bind a = get_var a in
+              let%bind b = get_var b in
+              ok (a, b)
+          | _ -> simple_fail "complex patterns not supported yet"
+        in
+        ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil}
+    | _ -> simple_fail "complex patterns not supported yet"
+
+  and simpl_instruction_block (t:Raw.instruction) : block result =
+    match t with
+    | Single s -> let%bind i = simpl_single_instruction s in ok [ i ]
+    | Block b -> simpl_block b.value
+
+  and simpl_instruction (t:Raw.instruction) : instruction result =
+    match t with
+    | Single s -> simpl_single_instruction s
+    | Block _ -> simple_fail "no block instruction yet"
+
+  and simpl_block (t:Raw.block) : block result =
+    bind_list @@ List.map simpl_instruction (npseq_to_list t.instr)
 
   let simpl_program (t:Raw.ast) : program result =
     bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl

src/ligo/ast_typed.ml

@@ -42,6 +42,7 @@ and expression =
   | Literal of literal
   | Constant of name * ae list (* For language constants, like (Cons hd tl) or (plus i j) *)
   | Variable of name
+  | Application of ae * ae
   | Lambda of {
       binder: name ;
       input_type: tv ;
@@ -60,6 +61,7 @@ and expression =
 
 
 and literal =
+  | Unit
   | Bool of bool
   | Int of int
   | Nat of int
@@ -91,22 +93,59 @@ and matching =
     }
   | Match_tuple of (name * b) list
 
+module PP = struct
+  open Format
+  open Ligo_helpers.PP
+
+  let rec type_value ppf (tv:type_value) : unit =
+    match tv with
+    | Type_tuple lst -> fprintf ppf "tuple[%a]" (list_sep type_value) lst
+    | Type_sum m -> fprintf ppf "sum[%a]" (smap_sep type_value) m
+    | Type_record m -> fprintf ppf "record[%a]" (smap_sep type_value) m
+    | Type_function (a, b) -> fprintf ppf "%a -> %a" type_value a type_value b
+    | Type_constant (c, []) -> fprintf ppf "%s" c
+    | Type_constant (c, n) -> fprintf ppf "%s(%a)" c (list_sep type_value) n
+end
+
 open Ligo_helpers.Trace
 
+module Errors = struct
+  let different_kinds a b =
+    let title = "different kinds" in
+    let full = Format.asprintf "(%a) VS (%a)" PP.type_value a PP.type_value b in
+    error title full
+
+  let different_constants a b =
+    let title = "different constants" in
+    let full = Format.asprintf "%s VS %s" a b in
+    error title full
+
+  let different_size_constants a b =
+    let title = "constants have different sizes" in
+    let full = Format.asprintf "%a VS %a" PP.type_value a PP.type_value b in
+    error title full
+
+  let different_size_tuples a b =
+    let title = "tuple have different sizes" in
+    let full = Format.asprintf "%a VS %a" PP.type_value a PP.type_value b in
+    error title full
+end
+open Errors
+
 let rec type_value_eq (ab: (type_value * type_value)) : unit result = match ab with
-  | Type_tuple a, Type_tuple b -> (
+  | Type_tuple a as ta, (Type_tuple b as tb) -> (
       let%bind _ =
-        Assert.assert_true ~msg:"tuples with different sizes"
+        trace_strong (different_size_tuples ta tb)
-        @@ List.(length a = length b) in
+        @@ Assert.assert_true List.(length a = length b) in
       bind_list_iter type_value_eq (List.combine a b)
     )
-  | Type_constant (a, a'), Type_constant (b, b') -> (
+  | Type_constant (a, a') as ca, (Type_constant (b, b') as cb) -> (
       let%bind _ =
-        Assert.assert_true ~msg:"constants with different sizes"
+        trace_strong (different_size_constants ca cb)
-        @@ List.(length a' = length b') in
+        @@ Assert.assert_true List.(length a' = length b') in
       let%bind _ =
-        Assert.assert_true ~msg:"constants with different names"
+        trace_strong (different_constants a b)
-        @@ (a = b) in
+        @@ Assert.assert_true (a = b) in
       trace (simple_error "constant sub-expression")
       @@ bind_list_iter type_value_eq (List.combine a' b')
     )
@@ -136,7 +175,7 @@ let rec type_value_eq (ab: (type_value * type_value)) : unit result = match ab w
       @@ bind_list_iter aux (List.combine a' b')
 
     )
-  | _ -> simple_fail "Different kinds of types"
+  | a, b -> fail @@ different_kinds a b
 
 let merge_annotation (a:type_value option) (b:type_value option) : type_value result =
   match a, b with
@@ -151,6 +190,7 @@ let t_bool : type_value = Type_constant ("bool", [])
 let t_string : type_value = Type_constant ("string", [])
 let t_bytes : type_value = Type_constant ("bytes", [])
 let t_int : type_value = Type_constant ("int", [])
+let t_unit : type_value = Type_constant ("unit", [])
 
 let get_annotation (x:annotated_expression) = x.type_annotation
 

src/ligo/contracts/toto.ligo

@@ -0,0 +1,8 @@
+type toto is record
+  a : nat ;
+  b : nat
+end
+
+const foo : int = 3
+
+

src/ligo/dune

@@ -13,3 +13,10 @@
   )
   (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 ))
 )
+
+(alias
+  (name runtest)
+  (action (run test/test.exe))
+  (deps (glob_files contracts/*))
+
+)

src/ligo/ligo-helpers/PP.ml

@@ -0,0 +1,12 @@
+open Format
+module SMap = X_map.String
+
+let const s ppf () = pp_print_string ppf s
+
+let list_sep pp = pp_print_list ~pp_sep:(const " ; ") pp
+let pair_sep pp ppf (a, b) = fprintf ppf "(%a, %a)" pp a pp b
+let smap_sep pp ppf m =
+  let aux k v prev = (k, v) :: prev in
+  let new_pp ppf (k, v) = fprintf ppf "%s -> %a" k pp v in
+  let lst = List.rev @@ SMap.fold aux m [] in
+  fprintf ppf "%a" (list_sep new_pp) lst

src/ligo/ligo-helpers/trace.ml

@@ -34,6 +34,10 @@ module Let_syntax = struct
   let bind m ~f = m >>? f
 end
 
+let trace_strong err = function
+  | Ok _ as o -> o
+  | Errors _ -> Errors [err]
+
 let trace err = function
   | Ok _ as o -> o
   | Errors errs -> Errors (err :: errs)
@@ -151,9 +155,9 @@ let pp_to_string pp () x =
 let errors_to_string = pp_to_string errors_pp
 
 module Assert = struct
-  let assert_true ~msg = function
+  let assert_true ?msg = function
     | true -> ok ()
-    | false -> simple_fail msg
+    | false -> simple_fail @@ Option.unopt ~default:"not true" msg
 
   let assert_equal_int ?msg a b =
     let msg = Option.unopt ~default:"not equal int" msg in

src/ligo/ligo.ml

@@ -48,8 +48,8 @@ let parse (s:string) : AST_Raw.t result =
   ok program_cst
 
 
-let abstract (p:AST_Raw.t) : AST_Simplified.program result = AST_Simplified.Simplify.program p
+let simplify (p:AST_Raw.t) : Ast_simplified.program result = AST_Simplified.Simplify.simpl_program p
 
-let annotate_types (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p
+let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p
 
 let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p

src/ligo/test/test.ml

@@ -11,159 +11,43 @@ let test name f =
       Format.printf "Errors : {\n%a}\n%!" errors_pp errs ;
       raise Alcotest.Test_error
 
-open Mini_c
-open Combinators
-
-module Mini_c = struct
-
-  let simple_int_program body : program = [
-    Fun("main", function_int body)
-  ]
-
-  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 =
+  let pass (source:string) : unit result =
-    parse_file source >>? fun program_ast ->
+    let%bind raw =
-    Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
+      trace (simple_error "parsing") @@
-    Ligo.Run.run typed_program input >>? fun output ->
+      parse_file source in
-    ok output
+    let%bind simplified =
-
+      trace (simple_error "simplifying") @@
-  let assert_value_int : Ligo.Typed.Value.value -> int result = function
+      simplify raw in
-    | `Constant (`Int n) -> ok n
+    let%bind typed =
-    | _ -> simple_fail "not an int"
+      trace (simple_error "typing") @@
+      type_ simplified in
+    let%bind _mini_c =
+      trace (simple_error "transpiling") @@
+      transpile typed in
+    ok ()
 
   let basic () : unit result =
-    run "./contracts/toto.ligo" (Ligo.Typed.Value.int 42) >>? fun output ->
+    Format.printf "basic test" ;
-    assert_value_int output >>? fun output ->
+    pass "./contracts/toto.ligo"
-    Assert.assert_equal_int 42 output >>? fun () ->
-    ok ()
 
-  let display_basic () : unit result =
+  (* let display_basic () : unit result =
-    parse_file "./contracts/toto.ligo" >>? fun program_ast ->
+   *   parse_file "./contracts/toto.ligo" >>? fun program_ast ->
-    Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
+   *   Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
-    Ligo.Transpile.program_to_michelson typed_program >>? fun node ->
+   *   Ligo.Transpile.program_to_michelson typed_program >>? fun node ->
-    let node = Tezos_utils.Cast.flatten_node node in
+   *   let node = Tezos_utils.Cast.flatten_node node in
-    let str = Tezos_utils.Cast.node_to_string node in
+   *   let str = Tezos_utils.Cast.node_to_string node in
-    Format.printf "Program:\n%s\n%!" str ;
+   *   Format.printf "Program:\n%s\n%!" str ;
-    ok ()
+   *   ok () *)
 
   let main = "Ligo", [
       test "basic" basic ;
-      test "basic.display" display_basic ;
     ]
 end
 
 let () =
   (* Printexc.record_backtrace true ; *)
   Alcotest.run "LIGO" [
-    main ;
+    Ligo.main ;
   ] ;
   ()

src/ligo/transpiler.ml

@@ -66,7 +66,12 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
   | Literal (Nat n) -> ok (Literal (`Nat n), tv, env)
   | Literal (Bytes s) -> ok (Literal (`Bytes s), tv, env)
   | Literal (String s) -> ok (Literal (`String s), tv, env)
+  | Literal Unit -> ok (Literal `Unit, tv, env)
   | Variable name -> ok (Var name, tv, env)
+  | Application (a, b) ->
+      let%bind a = translate_annotated_expression env a in
+      let%bind b = translate_annotated_expression env b in
+      ok (Apply (a, b), tv, env)
   | Constructor (m, param) ->
       let%bind (param'_expr, param'_tv, _) = translate_annotated_expression env ae in
       let%bind map_tv = AST.get_t_sum ae.type_annotation in

src/ligo/typer.ml

@@ -32,10 +32,39 @@ module Environment = struct
     List.assoc_opt s e.type_environment
   let add_type (e:t) (s:string) (tv:ele) : t =
     {e with type_environment = (s, tv) :: e.type_environment}
+
+  module PP = struct
+    open Format
+    open Ligo_helpers.PP
+
+    let value ppf (e:t) =
+      let pp ppf (s, e) = fprintf ppf "%s -> %a" s O.PP.type_value e in
+      fprintf ppf "ValueEnv[%a]" (list_sep pp) e.environment
+
+    let type_ ppf e =
+      let pp ppf (s, e) = fprintf ppf "%s -> %a" s O.PP.type_value e in
+      fprintf ppf "TypeEnv[%a]" (list_sep pp) e.type_environment
+
+    let full ppf e =
+      fprintf ppf "%a\n%a" value e type_ e
+  end
 end
 
 type environment = Environment.t
 
+module Errors = struct
+  let unbound_type_variable (e:environment) (n:string) =
+    let title = "unbound type variable" in
+    let full = Format.asprintf "%s in %a" n Environment.PP.type_ e in
+    error title full
+
+  let unrecognized_constant (n:string) =
+    let title = "unrecognized constant" in
+    let full = n in
+    error title full
+end
+open Errors
+
 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
@@ -99,6 +128,7 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
       let%bind m' = type_match e m in
       let%bind ex' = type_annotated_expression e ex in
       ok (e, O.Matching (ex', m'))
+  | Record_patch _ -> simple_fail "no record_patch yet"
 
 and type_match (e:environment) : I.matching -> O.matching result = function
   | Match_bool {match_true ; match_false} ->
@@ -148,7 +178,7 @@ and evaluate_type (e:environment) : I.type_expression -> O.type_value result = f
       ok (O.Type_record m)
   | Type_variable name ->
       let%bind tv =
-        trace_option (simple_error "unbound type variable")
+        trace_option (unbound_type_variable e name)
         @@ Environment.get_type e name in
       ok tv
   | Type_constant (cst, lst) ->
@@ -171,6 +201,9 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
   | Literal (Bool b) ->
       let%bind type_annotation = check O.t_bool in
       ok O.{expression = Literal (Bool b) ; type_annotation }
+  | Literal Unit ->
+      let%bind type_annotation = check O.t_unit in
+      ok O.{expression = Literal (Unit) ; type_annotation }
   | Literal (String s) ->
       let%bind type_annotation = check O.t_string in
       ok O.{expression = Literal (String s) ; type_annotation }
@@ -241,13 +274,23 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
       let%bind (name', tv) = type_constant name tv_lst in
       let%bind type_annotation = check tv in
       ok O.{expression = O.Constant (name', lst') ; type_annotation}
+  | Application (f, arg) ->
+      let%bind f = type_annotated_expression e f in
+      let%bind arg = type_annotated_expression e arg in
+      let%bind type_annotation = match f.type_annotation with
+        | Type_function (param, result) ->
+            let%bind _ = O.type_value_eq (param, arg.type_annotation) in
+            ok result
+        | _ -> simple_fail "applying to not-a-function"
+      in
+      ok O.{expression = Application (f, arg) ; type_annotation}
 
 and type_constant (name:string) (lst:O.type_value list) : (string * O.type_value) result =
   (* Constant poorman's polymorphism *)
   let open O in
   match (name, lst) with
-  | "add", [a ; b] when a = t_int && b = t_int -> ok ("add_int", t_int)
+  | "ADD", [a ; b] when a = t_int && b = t_int -> ok ("ADD_INT", t_int)
-  | "add", [a ; b] when a = t_string && b = t_string -> ok ("concat_string", t_string)
+  | "ADD", [a ; b] when a = t_string && b = t_string -> ok ("CONCAT", t_string)
-  | "add", [_ ; _] -> simple_fail "bad types to add"
+  | "ADD", [_ ; _] -> simple_fail "bad types to add"
-  | "add", _ -> simple_fail "bad number of params to add"
+  | "ADD", _ -> simple_fail "bad number of params to add"
-  | _ -> simple_fail "unrecognized constant"
+  | name, _ -> fail @@ unrecognized_constant name