Merge branch 'master' of gitlab.com:ligolang/ligo

src/parser/ligodity/AST.ml

@@ -328,6 +328,7 @@ and let_in = {
 and fun_expr = {
   kwd_fun : kwd_fun;
   param   : variable;
+  p_annot : (colon * type_expr) option;
   arrow   : arrow;
   body    : expr
 }
@@ -736,9 +737,13 @@ and print_let_in (bind: let_in) =
   print_expr body
 
 and print_fun_expr {value; _} =
-  let {kwd_fun; param; arrow; body} = value in
+  let {kwd_fun; param; p_annot; arrow; body} = value in
   print_token kwd_fun "fun";
-  print_var param;
+  (match p_annot with
+     None -> print_var param
+   | Some (colon, type_expr) ->
+      print_token colon ":";
+      print_type_expr type_expr);
   print_token arrow "->";
   print_expr body
 

src/parser/ligodity/AST.mli

@@ -337,6 +337,7 @@ and let_in = {
 and fun_expr = {
   kwd_fun : kwd_fun;
   param   : variable;
+  p_annot : (colon * type_expr) option;
   arrow   : arrow;
   body    : expr
 }

src/parser/ligodity/Parser.mly

@@ -131,9 +131,32 @@ let norm_fun_expr patterns expr =
         let fun_expr = {
           kwd_fun = ghost;
           param   = var;
+          p_annot = None;
           arrow   = ghost;
           body    = expr}
         in EFun (ghost_of fun_expr)
+    | PTyped p ->
+        let pattern = p.value.pattern
+        and type_expr = p.value.type_expr in
+        let fresh = Utils.gen_sym () |> ghost_of in
+        let clause = {pattern; arrow=ghost; rhs=expr} in
+        let clause = ghost_of clause in
+        let cases = ghost_of (clause, []) in
+        let case = {
+          kwd_match = ghost;
+          expr      = EVar fresh;
+          opening   = With ghost;
+          lead_vbar = None;
+          cases;
+          closing   = End ghost} in
+        let case = ECase (ghost_of case) in
+        let fun_expr = {
+          kwd_fun = ghost;
+          param   = fresh;
+          p_annot = Some (p.value.colon, type_expr);
+          arrow   = ghost;
+          body    = case}
+        in EFun (ghost_of fun_expr)
     | _ -> let fresh = Utils.gen_sym () |> ghost_of in
           let clause = {pattern; arrow=ghost; rhs=expr} in
           let clause = ghost_of clause in
@@ -149,6 +172,7 @@ let norm_fun_expr patterns expr =
           let fun_expr = {
             kwd_fun = ghost;
             param   = fresh;
+            p_annot = None;
             arrow   = ghost;
             body    = case}
           in EFun (ghost_of fun_expr)

src/simplify/ligodity.ml

@@ -109,7 +109,7 @@ let rec simpl_expression :
           lhs_type in
       let%bind rhs = simpl_expression ?te_annot:type_annotation let_rhs in
       let%bind body = simpl_expression body in
-      return (mk_let_in (variable.value , None) rhs body)
+      return @@ mk_let_in (variable.value , None) rhs body
     )
   | Raw.EAnnot a -> (
       let (expr , type_expr) = a.value in
@@ -206,8 +206,37 @@ let rec simpl_expression :
         @@ npseq_to_list c.value.cases.value in
       let%bind cases = simpl_cases lst in
       return @@ E_matching (e, cases)
-  | _ -> failwith "XXX" (* TODO *)
+  | EFun lamb ->
-
+      let%bind input_type = bind_map_option
+        (fun (_,type_expr) -> simpl_type_expression type_expr)
+        lamb.value.p_annot in
+      let body, body_type =
+        match lamb.value.body with
+          EAnnot {value = expr, type_expr} -> expr, Some type_expr
+        | expr -> expr, None in
+      let%bind output_type =
+        bind_map_option simpl_type_expression body_type in
+      let%bind result = simpl_expression body in
+      let binder = lamb.value.param.value, input_type in
+      let lambda = {binder; input_type; output_type; result = result}
+      in return @@ E_lambda lambda
+  | ESeq s ->
+      let items : Raw.expr list = pseq_to_list s.value.elements in
+      (match items with
+         [] -> return @@ E_skip
+       | expr::more ->
+          let expr' = simpl_expression expr in
+          let apply (e1: Raw.expr) (e2: expression Trace.result) =
+            let%bind a = simpl_expression e1 in
+            let%bind e2' = e2 in
+            return @@ E_sequence (a, e2')
+          in List.fold_right apply more expr')
+  | ECond c ->
+      let c = c.value in
+      let%bind expr = simpl_expression c.test in
+      let%bind match_true = simpl_expression c.ifso in
+      let%bind match_false = simpl_expression c.ifnot in
+      return @@ E_matching (expr, (Match_bool {match_true; match_false}))
 and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
   let return x = ok @@ make_option_typed x te_annot in
   match t with

src/test/dune-project

@@ -1 +0,0 @@
-(lang dune 1.6)