From af8e9bd238cbd097e4a0e38b8293a497d0aa06db Mon Sep 17 00:00:00 2001
From: Christian Rinderknecht <Christian.Rinderknecht@tezcore.com>
Date: Tue, 28 May 2019 17:00:43 +0200
Subject: [PATCH] Added simplifications of Ligodity for lambdas, sequences and
 conditionals.

Enabled in parser a type annotation on lambda parameter, and
lifted the existing type annotation in patterns to become that
type annotation.
---
 src/parser/ligodity/AST.ml     |  9 +++++++--
 src/parser/ligodity/AST.mli    |  1 +
 src/parser/ligodity/Parser.mly | 24 +++++++++++++++++++++++
 src/simplify/ligodity.ml       | 35 +++++++++++++++++++++++++++++++---
 src/test/dune-project          |  1 -
 5 files changed, 64 insertions(+), 6 deletions(-)
 delete mode 100644 src/test/dune-project

diff --git a/src/parser/ligodity/AST.ml b/src/parser/ligodity/AST.ml
index 4abc639ce..749db38ef 100644
--- a/src/parser/ligodity/AST.ml
+++ b/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
 
diff --git a/src/parser/ligodity/AST.mli b/src/parser/ligodity/AST.mli
index 6d237fe34..f23b40375 100644
--- a/src/parser/ligodity/AST.mli
+++ b/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
 }
diff --git a/src/parser/ligodity/Parser.mly b/src/parser/ligodity/Parser.mly
index f446b9ab7..3c7f57a7e 100644
--- a/src/parser/ligodity/Parser.mly
+++ b/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)
diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml
index a7c4c708a..0c3398758 100644
--- a/src/simplify/ligodity.ml
+++ b/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
diff --git a/src/test/dune-project b/src/test/dune-project
deleted file mode 100644
index a26d6e273..000000000
--- a/src/test/dune-project
+++ /dev/null
@@ -1 +0,0 @@
-(lang dune 1.6)