more camligo

src/lib_utils/location.ml

@@ -31,6 +31,7 @@ type 'a wrap = {
 let wrap ~loc wrap_content = { wrap_content ; location = loc }
 let unwrap { wrap_content ; _ } = wrap_content
 let map f x = { x with wrap_content = f x.wrap_content }
+let pp_wrap f ppf { wrap_content ; _ } = Format.fprintf ppf "%a" f wrap_content
 
 let lift_region : 'a Region.reg -> 'a wrap = fun x ->
   wrap ~loc:(File x.region) x.value

src/lib_utils/trace.ml

@@ -291,7 +291,7 @@ let sys_command command =
   | 0 -> ok ()
   | n -> fail (fun () -> error (thunk "Nonzero return code") (fun () -> (string_of_int n)) ())
 
-let sequence f lst =
+let trace_sequence f lst =
   let lazy_map_force : 'a . (unit -> 'a) list -> (unit -> 'a list) = fun l ->
     fun () ->
     List.rev @@ List.rev_map (fun a -> a ()) l in

src/lib_utils/x_list.ml

@@ -91,6 +91,14 @@ let rev_uncons_opt = function
       let hds = rev @@ tl r in
       Some (hds, last)
 
+let to_pair = function
+  | [a ; b] -> Some (a , b)
+  | _ -> None
+
+let to_singleton = function
+  | [a] -> Some a
+  | _ -> None
+
 module Ne = struct
 
   type 'a t = 'a * 'a list

src/ligo/ast_simplified/PP.ml

@@ -39,6 +39,8 @@ let rec expression ppf (e:expression) = match e with
         block body annotated_expression result
   | E_matching (ae, m) ->
       fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
+  | E_failwith ae ->
+      fprintf ppf "failwith %a" annotated_expression ae
 
 and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) ->
   fprintf ppf "%a -> %a" annotated_expression a annotated_expression b
@@ -85,7 +87,7 @@ and matching : type a . (formatter -> a -> unit) -> formatter -> a matching -> u
 
 and instruction ppf (i:instruction) = match i with
   | I_skip -> fprintf ppf "skip"
-  | I_fail ae -> fprintf ppf "fail with (%a)" annotated_expression ae
+  | I_do ae -> fprintf ppf "do %a" annotated_expression ae
   | I_record_patch (name, path, lst) -> fprintf ppf "%s.%a[%a]" name access_path path (list_sep_d single_record_patch) lst
   | I_loop (cond, b) -> fprintf ppf "while (%a) { %a }" annotated_expression cond block b
   | I_assignment {name;annotated_expression = ae} ->

src/ligo/ast_simplified/ast_simplified.ml

@@ -1,5 +1,6 @@
 include Types
 include Misc
+include Combinators
 
 module Types = Types
 module Misc = Misc

src/ligo/ast_simplified/combinators.ml

@@ -6,10 +6,13 @@ module SMap = Map.String
 let get_name : named_expression -> string = fun x -> x.name
 let get_type_name : named_type_expression -> string = fun x -> x.type_name
 let get_type_annotation (x:annotated_expression) = x.type_annotation
+let get_expression (x:annotated_expression) = x.expression
 
 let i_assignment : _ -> instruction = fun x -> I_assignment x
 let named_expression name annotated_expression = { name ; annotated_expression }
 let named_typed_expression name expression ty = { name ; annotated_expression = { expression ; type_annotation = Some ty } }
+let typed_expression expression ty = { expression ; type_annotation = Some ty }
+let untyped_expression expression = { expression ; type_annotation = None }
 
 let get_untyped_expression : annotated_expression -> expression result = fun ae ->
   let%bind () =
@@ -26,6 +29,7 @@ let t_nat       : type_expression = T_constant ("nat", [])
 let t_unit      : type_expression = T_constant ("unit", [])
 let t_option  o : type_expression = T_constant ("option", [o])
 let t_list  t : type_expression = T_constant ("list", [t])
+let t_variable n : type_expression = T_variable n
 let t_tuple lst : type_expression = T_tuple lst
 let t_pair (a , b) = t_tuple [a ; b]
 let t_record m  : type_expression = (T_record m)
@@ -68,11 +72,16 @@ let e_map lst : expression = E_map lst
 let e_list lst : expression = E_list lst
 let e_pair a b : expression = E_tuple [a; b]
 let e_constructor s a : expression = E_constructor (s , a)
+let e_match a b : expression = E_matching (a , b)
+let e_match_bool a b c : expression = e_match a (Match_bool {match_true = b ; match_false = c})
+let e_accessor a b = E_accessor (a , b)
+let e_accessor_props a b = e_accessor a (List.map (fun x -> Access_record x) b)
+let e_variable v = E_variable v
 
+let e_a_unit : annotated_expression = make_e_a_full (e_unit ()) t_unit
 let e_a_int n : annotated_expression = make_e_a_full (e_int n) t_int
 let e_a_nat n : annotated_expression = make_e_a_full (e_nat n) t_nat
 let e_a_bool b : annotated_expression = make_e_a_full (e_bool b) t_bool
-let e_a_unit : annotated_expression = make_e_a_full (e_unit ()) t_unit
 let e_a_constructor s a : annotated_expression = make_e_a (e_constructor s a)
 
 let e_a_record r =

src/ligo/ast_simplified/types.ml

@@ -70,6 +70,7 @@ and expression =
   | E_look_up of (ae * ae)
   (* Matching *)
   | E_matching of (ae * matching_expr)
+  | E_failwith of ae
 
 and access =
   | Access_tuple of int
@@ -93,7 +94,7 @@ and instruction =
   | I_matching of ae * matching_instr
   | I_loop of ae * b
   | I_skip
-  | I_fail of ae
+  | I_do of ae
   | I_record_patch of name * access_path * (string * ae) list
 
 and 'a matching =

src/ligo/ast_typed/PP.ml

@@ -46,6 +46,7 @@ and expression ppf (e:expression) : unit =
   | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i
   | E_matching (ae, m) ->
       fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
+  | E_failwith ae -> fprintf ppf "failwith %a" annotated_expression ae
 
 and value ppf v = annotated_expression ppf v
 
@@ -88,7 +89,7 @@ and pre_access ppf (a:access) = match a with
 
 and instruction ppf (i:instruction) = match i with
   | I_skip -> fprintf ppf "skip"
-  | I_fail ae -> fprintf ppf "fail with (%a)" annotated_expression ae
+  | I_do ae -> fprintf ppf "do %a" annotated_expression ae
   | I_loop (cond, b) -> fprintf ppf "while (%a) {@;  @[<v>%a@]@;}" annotated_expression cond block b
   | I_declaration {name;annotated_expression = ae} ->
       fprintf ppf "let %s = %a" name annotated_expression ae

src/ligo/ast_typed/misc.ml

@@ -61,6 +61,7 @@ module Free_variables = struct
     | E_map m -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
     | E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
     | E_matching (a , cs) -> union (self a) (matching_expression b cs)
+    | E_failwith a -> self a
 
   and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae ->
     expression b ae.expression
@@ -70,7 +71,7 @@ module Free_variables = struct
     | I_declaration n -> union (singleton n.name) b , (annotated_expression b n.annotated_expression)
     | I_assignment n -> b , (annotated_expression b n.annotated_expression)
     | I_skip -> b , empty
-    | I_fail e -> b , annotated_expression b e
+    | I_do e -> b , annotated_expression b e
     | I_loop (a , bl) -> b , union (annotated_expression b a) (block b bl)
     | I_patch (_ , _ , a) -> b , annotated_expression b a
     | I_matching (a , cs) -> b , union (annotated_expression b a) (matching_block b cs)

src/ligo/ast_typed/types.ml

@@ -89,6 +89,7 @@ and expression =
   | E_look_up of (ae * ae)
   (* Advanced *)
   | E_matching of (ae * matching_expr)
+  | E_failwith of ae
 
 and value = annotated_expression (* todo (for refactoring) *)
 
@@ -108,8 +109,8 @@ and instruction =
   | I_assignment of named_expression
   | I_matching of ae * matching_instr
   | I_loop of ae * b
+  | I_do of ae
   | I_skip
-  | I_fail of ae
   | I_patch of named_type_value * access_path * ae
 
 and access = Ast_simplified.access

src/ligo/contracts/new-syntax.mligo

@@ -3,78 +3,21 @@
 
 (** Type of storage for this contract *)
 type storage = {
-  voters : (address, unit) big_map; (** Used to register voters *)
-  votes : (string, nat) map; (** Keep track of vote counts *)
-  addresses : (string, key_hash) map; (** Addresses for payout *)
-  deadline : timestamp; (** Deadline after which vote closes *)
+  challenge : string ;
 }
 
 (** Initial storage *)
-let%init storage addresses = {
-  (* Initialize vote counts to zero *)
-  votes = Map.fold (fun ((name, _kh), votes) ->
-      Map.add name 0p votes
-    ) addresses Map;
-  addresses;
-  voters = BigMap ; (* No voters *)
-  deadline = Current.time () + 3600 * 24 (* 1 day from now *)
+let%init storage = {
+  challenge = "" ;
 }
 
-(** Entry point for voting.
-    @param choice A string corresponding to the candidate *)
-let%entry vote choice storage =
-  (* Only allowed while voting period is ongoing *)
-  if Current.time () > storage.deadline then failwith "Voting closed";
-  (* Voter must send at least 5tz to vote *)
-  if Current.amount () < 5.00tz then
-    failwith "Not enough money, at least 5tz to vote";
-  (* Voter cannot vote twice *)
-  if Map.mem (Current.sender ()) storage.voters then
-    failwith ("Has already voted", Current.sender ());
-  let votes = storage.votes in
-  match Map.find choice votes with
-  | None ->
-    (* Vote must be for an existing candidate *)
-    failwith ("Bad vote", choice)
-  | Some x ->
-    (* Increase vote count for candidate *)
-    let storage = storage.votes <- Map.add choice (x + 1p) votes in
-    (* Register voter *)
-    let storage =
-      storage.voters <- Map.add (Current.sender ()) () storage.voters in
-    (* Return updated storage *)
-    ([], storage)
+type param = {
+  new_challenge : string ;
+  attempt : bytes ;
+}
 
-(* Auxiliary function : returns the list of candidates with the
-   maximum number of votes (there can be more than one in case of
-   draw). *)
-let find_winners votes =
-  let winners, _max =
-    Map.fold (fun ((name, nb), (winners, max)) ->
-        if nb = max then
-          name :: winners, max
-        else if nb > max then
-          [name], nb
-        else winners, max
-      ) votes ([], 0p) in
-  winners
-
-(** Entry point for paying winning candidates. *)
-let%entry payout () storage =
-  (* Only allowed once voting period is over *)
-  if Current.time () <= storage.deadline then failwith "Voting ongoing";
-  (* Indentify winners of vote *)
-  let winners = find_winners storage.votes in
-  (* Balance of contract is split equally between winners *)
-  let amount = match Current.balance () / List.length winners with
-    | None -> failwith "No winners"
-    | Some (v, _rem) -> v in
-  (* Generate transfer operations *)
-  let operations = List.map (fun name ->
-      let dest = match Map.find name storage.addresses with
-        | None -> failwith () (* This cannot happen *)
-        | Some d -> d in
-      Account.transfer ~amount ~dest
-    ) winners in
-  (* Return list of operations. Storage is unchanged *)
-  operations, storage
+let%entry attempt (p:param) storage =
+  if Crypto.hash (Bytes.pack p.attempt) <> Bytes.pack storage.challenge then failwith "Failed challenge" ;
+  let transfer = Operation.transfer sender 10tz in
+  let storage = storage.challenge <- p.new_challenge in
+  ([] , storage)

src/ligo/operators/operators.ml

@@ -22,6 +22,12 @@ module Simplify = struct
     ("int" , 1) ;
   ]
 
+  module Camligo = struct
+    let constants = [
+      ("Bytes.pack" , 1) ;
+    ]
+  end
+
 end
 
 module Typer = struct

src/ligo/parser/camligo/ast.ml

@@ -1 +0,0 @@
-include Ast_generated

src/ligo/parser/camligo/dune

@@ -8,7 +8,10 @@
   (modules ast ast_generated parser user)
   (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Tezos_utils ))
   (preprocess
-    (pps tezos-utils.ppx_let_generalized)
+    (pps
+      tezos-utils.ppx_let_generalized
+      ppx_deriving.std
+    )
   )
 )
 

src/ligo/parser/camligo/generator.ml

@@ -210,7 +210,7 @@ module Print_AST = struct
     let levels = List.Ne.map get_content ((get_content nh).levels) in
     let nops = List.Ne.concat levels in
     let name = get_name nh in
-    fprintf ppf "%s %s =@.@[%a@]" t
+    fprintf ppf "%s %s =@.@[%a@] [@@@@deriving show]" t
       name
       (list_sep (n_operator nh.content.prefix name) new_line) nops
 
@@ -543,6 +543,7 @@ module Expression = struct
   let le = infix "le" `Left LE
   let gt = infix "gt" `Left GT
   let eq = infix "eq" `Left EQUAL
+  let neq = infix "neq" `Left UNEQUAL
 
   let cons = infix "cons" `Left DOUBLE_COLON
 
@@ -580,8 +581,8 @@ module Expression = struct
   let main_hierarchy = O.name_hierarchy main_hierarchy_name "Eh" [
       [tuple] ;
       [type_annotation] ;
+      [lt ; le ; gt ; eq ; neq] ;
       [application] ;
-      [lt ; le ; gt ; eq] ;
       [assignment] ;
       [cons] ;
       [addition ; substraction] ;

src/ligo/parser/camligo/lex/generator.ml

@@ -138,6 +138,7 @@ let tokens = [
   symbol "->" "ARROW" ;
   symbol "<-" "LEFT_ARROW" ;
   symbol "<=" "LE" ;
+  symbol "<>" "UNEQUAL" ;
   symbol "<" "LT" ;
   symbol ">" "GT" ;
   symbol "-" "MINUS" ;

src/ligo/simplify/camligo.ml

@@ -7,6 +7,7 @@ open O.Combinators
 let unwrap : type a . a Location.wrap -> a = Location.unwrap
 
 let type_constants = Operators.Simplify.type_constants
+let constants = Operators.Simplify.Camligo.constants
 
 let type_variable : string -> O.type_expression result = fun str ->
   match List.assoc_opt str type_constants with
@@ -17,12 +18,23 @@ let type_variable : string -> O.type_expression result = fun str ->
 let get_param_restricted_pattern : I.param -> I.restricted_pattern Location.wrap result = fun p ->
   match p with
   | I.Param_restricted_pattern c -> ok c
-  | _ -> simple_fail "not a restricted param pattern"
+  | _ ->
+      let error =
+        let title () = "not a restricted param pattern" in
+        let content () = Format.asprintf "%a" I.pp_param p in
+        error title content in
+      fail error
 
 let get_unrestricted_pattern : I.restricted_pattern -> I.pattern Location.wrap result = fun rp ->
   match rp with
   | I.Pr_restrict p -> ok p
-  | _ -> simple_fail "not an unrestricted pattern"
+  | _ ->
+      let error =
+        let title () = "not an unrestricted param pattern" in
+        let content () = Format.asprintf "%a" I.pp_restricted_pattern rp in
+        error title content in
+      fail error
+
 
 let get_p_type_annotation : I.pattern -> (I.pattern Location.wrap * I.restricted_type_expression Location.wrap) result = fun p ->
   match p with
@@ -39,13 +51,21 @@ let get_p_typed_variable : I.pattern -> (string Location.wrap * I.restricted_typ
   let%bind var = get_p_variable (unwrap p') in
   ok (var , rte)
 
-let get_arg : I.param -> _ result = fun arg ->
-  let%bind rp =
-    get_param_restricted_pattern arg >>?
-    Function.compose get_unrestricted_pattern unwrap in
-  let%bind (var , rte) = get_p_typed_variable (unwrap rp) in
+let get_typed_variable_param : I.param -> _ result = fun arg ->
+  let%bind up =
+    let%bind rp = get_param_restricted_pattern arg in
+    let%bind up = get_unrestricted_pattern (unwrap rp) in
+    ok up in
+  let%bind (var , rte) = get_p_typed_variable (unwrap up) in
   ok (var , rte)
 
+let get_untyped_variable_param : I.param -> _ result = fun arg ->
+  let%bind rp = get_param_restricted_pattern arg in
+  let%bind var = match (unwrap rp) with
+    | I.Pr_variable v -> ok v
+    | _ -> simple_fail "a regular variable was expected" in
+  ok var
+
 let get_type_annotation_ : I.type_annotation_ -> I.type_expression Location.wrap result = fun p ->
     match p with
     | I.Type_annotation_ p -> ok p
@@ -54,6 +74,34 @@ let get_e_match_clause : I.e_match_clause -> (I.pattern Location.wrap * I.expres
   match e with
   | E_match_clause c -> ok c
 
+let match_clauses : type a . (I.pattern * a) list -> a O.matching result = fun _clauses ->
+  let match_bool _ = simple_fail "" in
+  let match_stuff _ = simple_fail "" in
+  bind_find_map_list (simple_error "no weird matching yet") (fun f -> f ()) [ match_bool ; match_stuff ]
+
+let rec of_no_match : I.expression_no_match -> I.expression = fun enm ->
+  let open I in
+  let self = Location.map of_no_match in
+  match enm with
+  | Em_let_in (a, b, c) -> E_let_in (a , self b , self c)
+  | Em_fun (a , b) -> E_fun (a , self b)
+  | Em_record r -> E_record r
+  | Em_ifthenelse (a , b , c) -> E_ifthenelse (self a , self b , self c)
+  | Em_ifthen (a , b) -> E_ifthen (self a , self b)
+  | Em_main m -> E_main m
+
+let rec of_no_seq : I.expression_no_seq -> I.expression = fun enm ->
+  let open I in
+  let self = Location.map of_no_seq in
+  match enm with
+  | Es_let_in (a, b, c) -> E_let_in (a , self b , self c)
+  | Es_fun (a , b) -> E_fun (a , self b)
+  | Es_record r -> E_record r
+  | Es_ifthenelse (a , b , c) -> E_ifthenelse (self a , self b , self c)
+  | Es_ifthen (a , b) -> E_ifthen (self a , self b)
+  | Es_match (a , b) -> E_match (self a , b)
+  | Es_main m -> E_main m
+
 let rec type_expression : I.type_expression -> O.type_expression result = fun te ->
   match te with
   | T_variable tv ->
@@ -110,121 +158,136 @@ let restricted_type_expression : I.restricted_type_expression -> O.type_expressi
       ok @@ unwrap tv'
   | Tr_paren te -> type_expression (unwrap te)
 
+type last_instruction_result = (O.block * O.annotated_expression)
+type lir = last_instruction_result
+
 let rec expression : I.expression -> O.annotated_expression result = fun e ->
+  let simple_error str =
+    let title () = Format.asprintf "No %s in inside expressions" str in
+    let content () = Format.asprintf "%a" I.pp_expression e in
+    error title content in
   match e with
-  | E_sequence _
-  | E_let_in _
-  | E_ifthen _
-  | E_ifthenelse _
-    -> simple_fail "not block expressions in local expressions yet"
-  | E_fun _ -> simple_fail "no local functions yet"
-  | E_match _ -> simple_fail "no match in expressions yet"
-  | E_main m ->
-      let%bind m' = bind_map_location expression_main m in
-      ok @@ unwrap m'
-  | E_record r -> expression_record r
+  | I.E_sequence _ -> fail @@ simple_error "sequence"
+  | I.E_let_in _ -> fail @@ simple_error "letin"
+  | I.E_ifthenelse ite -> ifthenelse ite
+  | I.E_ifthen it -> ifthen it
+  | I.E_match m -> match_ m
+  | I.E_record r -> record r
+  | I.E_fun _ -> fail @@ simple_error "fun"
+  | I.E_main m -> expression_main m
 
-and expression_no_match_block : I.expression_no_match -> O.block result = fun e ->
+and expression_last_instruction : I.expression -> lir result = fun e ->
   match e with
-  | I.Em_let_in _|I.Em_fun _|I.Em_record _|I.Em_ifthenelse _|I.Em_ifthen _
-  |I.Em_main _ -> simple_fail "lel"
+  | I.E_let_in l -> let_in_last_instruction l
+  | I.E_sequence s -> sequence_last_instruction s
+  | I.E_fun _|I.E_record _|I.E_ifthenelse _
+  |I.E_ifthen _|I.E_match _|I.E_main _ -> (
+      let%bind result' = expression e in
+      ok ([] , result')
+    )
 
-and sequence_block : I.expression Location.wrap list -> O.block result = fun s ->
-  let%bind blocks = bind_map_list (bind_map_location expression_block) s in
-  let block = List.(concat @@ map unwrap blocks) in
-  ok block
+and expression_sequence : I.expression -> O.instruction result = fun e ->
+  let%bind e' = expression e in
+  ok @@ O.I_do e'
 
-and let_in_block : (I.pattern Location.wrap * I.expression Location.wrap * I.expression Location.wrap) -> O.block result =
-  fun (var , expr , body) ->
-  let%bind (var' , te) = get_p_typed_variable (unwrap var) in
-  let%bind expr' =
-    let%bind expr' = bind_map_location expression expr in
-    bind_map_location O.Combinators.get_untyped_expression expr' in
-  let%bind te' = bind_map_location restricted_type_expression te in
-  let instruction = O.Combinators.(i_assignment @@ named_typed_expression (unwrap var') (unwrap expr') (unwrap te')) in
-  let%bind body' = bind_map_location expression_block body in
-  ok @@ instruction :: (unwrap body')
+and let_in_last_instruction :
+  I.pattern Location.wrap * I.expression Location.wrap * I.expression Location.wrap -> lir result
+  = fun l ->
+  let (pat , expr , body) = l in
+  let%bind (var , ty) = get_p_typed_variable (unwrap pat) in
+  let%bind ty' = restricted_type_expression (unwrap ty) in
+  let%bind expr' = expression (unwrap expr) in
+  let%bind uexpr' = get_untyped_expression expr' in
+  let%bind (body' , last') = expression_last_instruction (unwrap body) in
+  let assignment = O.(i_assignment @@ named_typed_expression (unwrap var) uexpr' ty') in
+  ok (assignment :: body' , last')
 
-and if_then_else_block : (I.expression Location.wrap * I.expression Location.wrap * I.expression Location.wrap) -> O.block result =
-  fun (cond , branch_true , branch_false) ->
+and sequence_last_instruction = fun s ->
+  let exprs = List.map unwrap s in
+  let%bind (hds , tl) =
+    trace_option (simple_error "at least 2 expressions in sequence") @@
+    List.rev_uncons_opt exprs in
+  let%bind instrs' = bind_map_list expression_sequence hds in
+  let%bind (body' , last') = expression_last_instruction tl in
+  ok (instrs' @ body' , last')
+
+and ifthenelse
+  : (I.expression Location.wrap * I.expression Location.wrap * I.expression Location.wrap) -> O.annotated_expression result
+  = fun ite ->
+  let (cond , branch_true , branch_false) = ite in
   let%bind cond' = bind_map_location expression cond in
-  let%bind branch_true' = bind_map_location expression_block branch_true in
-  let%bind branch_false' = bind_map_location expression_block branch_false in
-  ok [ O.I_matching ((unwrap cond') , Match_bool { match_true = (unwrap branch_true') ; match_false = (unwrap branch_false') }) ]
+  let%bind branch_true' = bind_map_location expression branch_true in
+  let%bind branch_false' = bind_map_location expression branch_false in
+  ok @@ O.(untyped_expression @@ e_match_bool (unwrap cond') (unwrap branch_true') (unwrap branch_false'))
 
-and if_then_block : (I.expression Location.wrap * I.expression Location.wrap) -> O.block result =
-  fun (cond , branch_true) ->
+and ifthen
+  : (I.expression Location.wrap * I.expression Location.wrap) -> O.annotated_expression result
+  = fun it ->
+  let (cond , branch_true) = it in
   let%bind cond' = bind_map_location expression cond in
-  let%bind branch_true' = bind_map_location expression_block branch_true in
-  let branch_false = O.I_skip in
-  ok [ O.I_matching ((unwrap cond') , Match_bool { match_true = (unwrap branch_true') ; match_false = [ branch_false ] }) ]
+  let%bind branch_true' = bind_map_location expression branch_true in
+  ok @@ O.(untyped_expression @@ e_match_bool (unwrap cond') (unwrap branch_true') e_a_unit)
 
-and match_clauses : type a . (I.pattern * a) list -> a O.matching result = fun _clauses ->
-  let match_bool _ = simple_fail "" in
-  let match_stuff _ = simple_fail "" in
-  bind_find_map_list (simple_error "no weird matching yet") (fun f -> f ()) [ match_bool ; match_stuff ]
-
-and match_block : _ -> O.block result = fun (case , clauses) ->
-  let%bind case' = bind_map_location expression case in
-  let%bind clauses' =
-    let u = List.map unwrap clauses in
-    let%bind cs = bind_map_list get_e_match_clause u in
-    let ucs = List.map (Tuple.map_h_2 unwrap unwrap) cs in
-    let%bind ucs' =
+and match_
+  : I.expression Location.wrap * I.e_match_clause Location.wrap list -> O.annotated_expression result
+  = fun m ->
+    let (expr , clauses) = m in
+    let%bind expr' = expression (unwrap expr) in
+    let%bind clauses' =
+      let%bind clauses =
+        bind_map_list get_e_match_clause
+        @@ List.map unwrap clauses in
       let aux (x , y) =
-        let%bind y' = expression_no_match_block y in
-        ok (x , y') in
-      bind_map_list aux ucs in
-    ok ucs' in
-  let%bind matching = match_clauses clauses' in
-  ok [ O.I_matching ((unwrap case') , matching) ]
+        let x' = unwrap x in
+        let%bind y' = expression @@ of_no_match @@ unwrap y in
+        ok (x' , y') in
+      bind_map_list aux clauses in
+    let%bind matching = match_clauses clauses' in
+    ok O.(untyped_expression @@ e_match expr' matching)
 
-and expression_block : I.expression -> O.block result = fun e ->
-  match e with
-  | I.E_sequence s -> sequence_block s
-  | I.E_let_in li -> let_in_block li
-  | I.E_ifthenelse ite -> if_then_else_block ite
-  | I.E_ifthen it -> if_then_block it
-  | I.E_match cc -> match_block cc
-  |I.E_fun _|I.E_record _
-  |I.E_main _ -> simple_fail "no regular expression in blocks"
-
-and expression_record : _ -> O.annotated_expression result = fun r ->
+and record
+  = fun r ->
   let aux : I.e_record_element -> _ = fun re ->
     match re with
     | E_record_element_record_implicit _ -> simple_fail "no implicit record element yet"
     | E_record_element_record_explicit (s, e) ->
-        let%bind e' = bind_map_location expression_no_seq e in
+        let%bind e' = bind_map_location (Function.compose expression of_no_seq) e in
         ok (s, e')
   in
   let%bind r' = bind_map_list (bind_map_location aux) r in
-  let e_map =
-    let lst = List.map ((fun (x, y) -> unwrap x, unwrap y) >| unwrap) r' in
-    let open Map.String in
-    List.fold_left (fun prec (k , v) -> add k v prec) empty lst
-  in
-  ok @@ O.(make_e_a @@ E_record e_map)
+  let lst = List.map ((fun (x, y) -> unwrap x, unwrap y) >| unwrap) r' in
+  ok @@ O.(untyped_expression @@ e_record lst)
 
-and expression_main : I.expression_main -> O.annotated_expression result = fun em ->
-  let return x = ok @@ make_e_a x in
+and expression_main : I.expression_main Location.wrap -> O.annotated_expression result = fun em ->
+  let return x = ok @@ untyped_expression x in
   let simple_binop name ab =
-    let%bind (a' , b') = bind_map_pair (bind_map_location expression_main) ab in
-    return @@ E_constant (name, [unwrap a' ; unwrap b']) in
-  match em with
+    let%bind (a' , b') = bind_map_pair expression_main ab in
+    return @@ E_constant (name, [a' ; b']) in
+  trace (
+    let title () = "simplifying main_expression" in
+    let content () = Format.asprintf "%a" I.pp_expression_main (unwrap em) in
+    error title content
+  ) @@
+  match (unwrap em) with
   | Eh_tuple lst ->
-      let%bind lst' = bind_map_list (bind_map_location expression_main) lst in
-      return @@ E_tuple (List.map unwrap lst')
-  | Eh_application farg ->
-      (* TODO: constructor case *)
-      let%bind farg' = bind_map_pair (bind_map_location expression_main) farg in
-      return @@ E_application (Tuple.map2 unwrap farg')
+      let%bind lst' = bind_map_list expression_main lst in
+      return @@ E_tuple lst'
+  | Eh_application (f , arg) -> (
+      let%bind arg' = expression_main arg in
+      match unwrap f with
+      | Eh_variable v -> identifier ([] , v) arg'
+      | Eh_module_ident (lst , v) -> identifier (lst , v) arg'
+      | _ -> (
+          let%bind f' = expression_main f in
+          return @@ E_application (f' , arg')
+        )
+    )
   | Eh_type_annotation (e, te) ->
-      let%bind e' = bind_map_location expression_main e in
-      let%bind e'' = match (unwrap e').type_annotation with
-        | None -> ok (unwrap e').expression
-        | Some _ -> simple_fail "can't double annotate" in
+      let%bind e' =
+        let%bind e' = expression_main e in
+        get_untyped_expression e' in
       let%bind te' = bind_map_location restricted_type_expression te in
-      ok @@ make_e_a_full e'' (unwrap te')
+      ok @@ typed_expression e' (unwrap te')
   | Eh_lt ab ->
       simple_binop "LT" ab
   | Eh_gt ab ->
@@ -233,6 +296,8 @@ and expression_main : I.expression_main -> O.annotated_expression result = fun e
       simple_binop "LE" ab
   | Eh_eq ab ->
       simple_binop "EQ" ab
+  | Eh_neq ab ->
+      simple_binop "NEQ" ab
   | Eh_cons ab ->
       simple_binop "CONS" ab
   | Eh_addition ab ->
@@ -252,7 +317,11 @@ and expression_main : I.expression_main -> O.annotated_expression result = fun e
   | Eh_tz _ ->
       simple_fail "tz literals not supported yet"
   | Eh_module_ident _ ->
-      simple_fail "modules not supported yet"
+      let error =
+        let title () = "modules not supported yet" in
+        let content () = Format.asprintf "%a" I.pp_expression_main (unwrap em) in
+        error title content in
+      fail error
   | Eh_variable v ->
       return @@ E_variable (unwrap v)
   | Eh_constructor _ ->
@@ -263,51 +332,133 @@ and expression_main : I.expression_main -> O.annotated_expression result = fun e
       simple_fail "named parameter not supported yet"
   | Eh_assign _ ->
       simple_fail "assign not supported yet"
-  | Eh_accessor _ ->
-      simple_fail "accessor not supported yet"
+  | Eh_accessor (src , path) ->
+      ok @@ O.(untyped_expression @@ e_accessor_props (untyped_expression @@ e_variable (unwrap src)) (List.map unwrap path))
   | Eh_bottom e ->
       expression (unwrap e)
 
-and expression_no_seq : I.expression_no_seq -> O.annotated_expression result = fun mns ->
-  match mns with
-  | Es_record r -> expression_record r
-  | Es_let_in _
-  | Es_ifthen _
-  | Es_ifthenelse _
-    -> simple_fail "not block expressions in local expressions yet"
-  | Es_fun _ -> simple_fail "no local functions yet"
-  | Es_match _ -> simple_fail "no match in expressions yet"
-  | Es_main e ->
-      expression_main (unwrap e)
+and identifier : (string Location.wrap) list * string Location.wrap -> _ -> _ result = fun (lst , v) param ->
+  let constant_name = String.concat "." ((List.map unwrap lst) @ [unwrap v]) in
+  match List.assoc_opt constant_name constants with
+  | Some n -> (
+      let params =
+        match get_expression param with
+        | E_tuple lst -> lst
+        | _ -> [ param ] in
+      let%bind () =
+        trace_strong (simple_error "bad constant arity") @@
+        Assert.assert_list_size params n in
+      ok O.(untyped_expression @@ E_constant (constant_name , params))
+    )
+  | None ->
+      let%bind () =
+        let error =
+          let title () = "no module identifiers yet" in
+          let content () = Format.asprintf "%s" constant_name in
+          error title content in
+        trace_strong error @@
+        Assert.assert_list_empty lst in
+      ok O.(untyped_expression @@ E_application (untyped_expression @@ E_variable (unwrap v) , param))
 
-let let_content : I.let_content -> _ result = fun (Let_content (n, args, ty_opt, e)) ->
+
+let let_content : I.let_content -> _ result = fun l ->
+  match l with
+  | (Let_content (n, args, ty_opt, e)) -> (
+      let%bind args' = bind_map_list (bind_map_location get_typed_variable_param) args in
+      let%bind ty' =
+        let%bind tya =
+          trace_option (simple_error "top-level declarations need a type") @@
+          ty_opt in
+        let%bind ty = get_type_annotation_ (unwrap tya) in
+        bind_map_location type_expression ty in
+      match args' with
+      | [] -> ( (* No arguments. Simplify as regular value. *)
+          let%bind e' =
+            let%bind e' = bind_map_location expression e in
+            bind_map_location O.Combinators.get_untyped_expression e' in
+          let ae = make_e_a_full (unwrap e') (unwrap ty') in
+          ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = ae}
+        )
+      | [_param] ->
+          simple_fail "no syntactic sugar for functions yet param"
+      | _lst -> ( (* Arguments without fun. *)
+          simple_fail "if you want currified functions, please do so explicitly"
+        )
+    )
+
+let let_entry : _ -> _ result = fun l ->
+  let (I.Let_content (n , args , ty_opt , e)) = l in
   let%bind () =
-    trace_strong (simple_error "no sugar-candy for args yet") @@
-    Assert.assert_list_empty args in
-  let%bind args' = bind_map_list (bind_map_location get_arg) args in
-  let%bind ty' =
-    let%bind tya =
-      trace_option (simple_error "top-level declarations need a type") @@
-      ty_opt in
-    let%bind ty = get_type_annotation_ (unwrap tya) in
-    bind_map_location type_expression ty in
-  match args' with
-  | [] -> ( (* No arguments. Simplify as regular value. *)
-      let%bind e' =
-        let%bind e' = bind_map_location expression e in
-        bind_map_location O.Combinators.get_untyped_expression e' in
-      let ae = make_e_a_full (unwrap e') (unwrap ty') in
-      ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = ae}
-    )
-  | _lst -> ( (* Arguments without fun. *)
-      simple_fail "no syntactic sugar for functions yet"
-    )
+    trace_strong (simple_error "entry-point shouldn't have type annotations") @@
+    Assert.assert_none ty_opt in
+  let%bind (param , storage) =
+    trace_option (simple_error "entry-points should have exactly two params") @@
+    List.to_pair args in
+  let%bind (param_name , param_ty) =
+    let%bind param' = bind_map_location get_typed_variable_param param in
+    let (param_name , param_ty) = unwrap param' in
+    let param_name' = unwrap param_name in
+    let%bind param_ty' = restricted_type_expression (unwrap param_ty) in
+    ok (param_name' , param_ty') in
+  let%bind storage_name = get_untyped_variable_param (unwrap storage) in
+  let storage_ty = O.T_variable "storage" in
+  let input_nty =
+    let ty = O.T_tuple [param_ty ; storage_ty] in
+    let nty = O.{type_name = "arguments" ; type_expression = ty} in
+    nty in
+  let input = O.Combinators.typed_expression (E_variable input_nty.type_name) input_nty.type_expression in
+  let tpl_declarations =
+    let aux = fun i (name , type_expression) ->
+      O.I_assignment {
+        name ;
+        annotated_expression = {
+          expression = O.E_accessor (input , [ Access_tuple i ]) ;
+          type_annotation = Some type_expression ;
+        }
+      }
+    in
+    List.mapi aux [ (param_name , param_ty) ; ((unwrap storage_name) , storage_ty)]
+  in
+  let%bind (body' , result) = expression_last_instruction (unwrap e) in
+  let lambda =
+    let output_type = O.(t_pair (t_list t_operation , storage_ty)) in
+    O.{
+      binder = input_nty.type_name ;
+      input_type = input_nty.type_expression ;
+      output_type ;
+      result ;
+      body = tpl_declarations @ body' ;
+    } in
+  let type_annotation = Some (O.T_function (lambda.input_type , lambda.output_type)) in
+  ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = {expression = O.E_lambda lambda ; type_annotation}}
+
+let let_init_storage : _ -> _ result = fun l ->
+  let (args , ty_opt , e) = l in
+  let%bind () =
+    trace_strong (simple_error "storage init shouldn't have a type annotation") @@
+    Assert.assert_none ty_opt in
+  let%bind () =
+    trace (simple_error "storage init should have no parameter (address)") @@
+    Assert.assert_list_size args 0 in
+  let%bind content =
+    let%bind ae = bind_map_location expression e in
+    bind_map_location get_untyped_expression ae
+  in
+  let type_annotation = O.t_variable "storage" in
+  ok @@ O.(Declaration_constant (named_typed_expression "storage" (unwrap content) type_annotation))
+
+
+let let_init_content : I.let_content -> _ result = fun l ->
+  let (I.Let_content (n, args, ty_opt, e)) = l in
+  match (unwrap n) with
+  | "storage" -> let_init_storage (args , ty_opt , e)
+  | _ -> simple_fail "%init directives are only used for storage"
 
 let statement : I.statement -> O.declaration result = fun s ->
   match s with
   | Statement_variable_declaration x -> let_content (unwrap x)
-  | Statement_init_declaration x -> let_content (unwrap x)
-  | Statement_entry_declaration x -> let_content (unwrap x)
+  | Statement_init_declaration x -> let_init_content (unwrap x)
+  | Statement_entry_declaration x -> let_entry (unwrap x)
   | Statement_type_declaration (n, te) ->
       let%bind te' = bind_map_location type_expression te in
       ok @@ O.Declaration_type {type_name = unwrap n ; type_expression = unwrap te'}

src/ligo/simplify/dune

@@ -8,7 +8,9 @@
     operators
   )
   (preprocess
-    (pps tezos-utils.ppx_let_generalized)
+    (pps
+      tezos-utils.ppx_let_generalized
+    )
   )
   (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils ))
 )

src/ligo/simplify/pascaligo.ml

@@ -395,7 +395,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
   | ProcCall _ -> simple_fail "no proc call"
   | Fail e ->
       let%bind expr = simpl_expression e.value.fail_expr in
-      ok @@ I_fail expr
+      ok @@ I_do (untyped_expression @@ E_failwith expr)
   | Skip _ -> ok @@ I_skip
   | Loop (While l) ->
       let l = l.value in

src/ligo/transpiler/transpiler.ml

@@ -172,7 +172,7 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
       let%bind body' = translate_block env' body in
       return (S_while (expr', body'))
   | I_skip -> ok []
-  | I_fail _ -> simple_fail "todo : fail"
+  | I_do _ae -> simple_fail "todo : do"
 
 and translate_literal : AST.literal -> value = fun l -> match l with
   | Literal_bool b -> D_bool b
@@ -206,6 +206,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
     ok @@ Combinators.Expression.make_tpl (expr, tv, env) in
   let f = translate_annotated_expression env in
   match ae.expression with
+  | E_failwith _ae -> simple_fail "todo : failwith"
   | E_literal l -> return @@ E_literal (translate_literal l)
   | E_variable name ->
       let%bind tv =

src/ligo/typer/typer.ml

@@ -92,9 +92,9 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
   let return x = ok (e, [x]) in
   match i with
   | I_skip -> return O.I_skip
-  | I_fail x ->
+  | I_do x ->
       let%bind expression = type_annotated_expression e x in
-      return @@ O.I_fail expression
+      return @@ O.I_do expression
   | I_loop (cond, body) ->
       let%bind cond = type_annotated_expression e cond in
       let%bind _ =
@@ -279,6 +279,7 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot
     ok @@ make_a_e expr type_annotation e in
   match ae.expression with
   (* Basic *)
+  | E_failwith _ -> simple_fail "can't type failwith in isolation"
   | E_variable name ->
       let%bind tv' =
         trace_option (unbound_variable e name)
@@ -554,6 +555,9 @@ let rec untype_annotated_expression (e:O.annotated_expression) : (I.annotated_ex
       let%bind ae' = untype_annotated_expression ae in
       let%bind m' = untype_matching untype_annotated_expression m in
       return (E_matching (ae', m'))
+  | E_failwith ae ->
+      let%bind ae' = untype_annotated_expression ae in
+      return (E_failwith ae')
 
 and untype_block (b:O.block) : (I.block) result =
   bind_list @@ List.map untype_instruction b
@@ -562,9 +566,9 @@ and untype_instruction (i:O.instruction) : (I.instruction) result =
   let open I in
   match i with
   | I_skip -> ok I_skip
-  | I_fail e ->
+  | I_do e ->
       let%bind e' = untype_annotated_expression e in
-      ok (I_fail e')
+      ok (I_do e')
   | I_loop (e, b) ->
       let%bind e' = untype_annotated_expression e in
       let%bind b' = untype_block b in