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)