diff --git a/lib/eval.ml b/lib/eval.ml index 5b0cff3..63f0c46 100644 --- a/lib/eval.ml +++ b/lib/eval.ml @@ -15,10 +15,10 @@ and function_type = { let rec eval_expr (scope: scope) (expr: Parser.expr_tree): value_type = match expr with - | Parser.LetExpr (Parser.Let (name, value_expr, in_expr)) -> - eval_let_expr scope name value_expr in_expr - | Parser.FunExpr (Parser.Fun (name, body_expr)) -> - eval_fun_expr scope name body_expr + | Parser.LetExpr (l) -> + eval_let_expr scope l.name l.value_expr l.in_expr + | Parser.FunExpr (ftree) -> + eval_fun_expr scope ftree | Parser.IfExpr (Parser.If (cond_expr, then_expr, else_expr)) -> eval_if_expr scope cond_expr then_expr else_expr | Parser.BinOpExpr (op, left_expr, right_expr) -> @@ -54,8 +54,8 @@ and eval_let_expr scope name value_expr in_expr = let value = eval_expr scope value_expr in let new_scope = { scope with bindings = VariableBindingMap.add name value scope.bindings } in eval_expr new_scope in_expr -and eval_fun_expr scope name body_expr = - Fun { argname = name; body = body_expr; scope = scope } +and eval_fun_expr scope (ftree: Parser.fun_expr_tree) = + Fun { argname = ftree.name; body = ftree.body_expr; scope = scope } and eval_bin_op_expr scope op left_expr right_expr = let left = eval_expr scope left_expr in let right = eval_expr scope right_expr in diff --git a/lib/lexer.ml b/lib/lexer.ml index 71a22eb..c0934e4 100644 --- a/lib/lexer.ml +++ b/lib/lexer.ml @@ -51,7 +51,7 @@ let%test "test: get_line_and_col 2" = let input_first (ctx: lexer_context) = if ctx.pos < String.length ctx.total then ctx.total.[ctx.pos] - else + else epsilon let%test "test first" = @@ -142,7 +142,7 @@ let id_to_token_type id = match (Token.str2keyword id) with | Some keyword -> keyword | None -> Token.Identifier id - + let lex_token (ctx: lexer_context) = let make_token token_type pos = {Token.token_type = token_type; pos = pos} in @@ -154,6 +154,7 @@ let lex_token (ctx: lexer_context) = | '\000' -> {Token.token_type = Eof; pos = pos}, ctx | '(' -> make_token LParen pos, rest | ')' -> make_token RParen pos, rest + | ':' -> make_token Colon pos, rest | '=' -> make_token Equal pos, rest | '+' -> make_token Add pos, rest | '-' -> diff --git a/lib/parser.ml b/lib/parser.ml index 9ffaf37..fd35a75 100644 --- a/lib/parser.ml +++ b/lib/parser.ml @@ -1,4 +1,4 @@ -open Lexer +(* open Lexer *) type parser_context = { seq: (Token.t * Lexer.lexer_context) Seq.t; @@ -22,6 +22,10 @@ let bind (a: 'a parser) (b:'a -> 'b parser) = fun (ctx: parser_context) -> | Some (a', ctx') -> b a' ctx' | None -> None + +let push_error (msg: string): unit parser = fun (ctx: parser_context) -> + Some ((), { ctx with errors = msg::ctx.errors }) + let (>>=) = bind let (let*) = bind @@ -40,6 +44,14 @@ let next_token: Token.t parser = fun (ctx: parser_context) -> { ctx with seq = s} )) +let rec eat_until: (Token.t -> bool) -> unit parser = fun (filter) -> + let* tt = peek_token in + if not (filter tt) then + let* _ = next_token in + eat_until filter + else + return () + let match_token (tt: Token.token_type) : Token.t parser = let* t = next_token in if t.token_type = tt then @@ -47,10 +59,13 @@ let match_token (tt: Token.token_type) : Token.t parser = else stop -let zero_or_one (p: 'a parser): ('a option) parser = fun (ctx) -> - match p ctx with - | Some (a, ctx') -> Some (Some a, ctx') - | None -> Some (None, ctx) +let match_identifier: string parser = + let* tt = next_token in + match tt.token_type with + | Token.Identifier id -> return id + | _ -> stop + +let zero_or_one (p: 'a parser): ('a option) parser = ((fmap (fun x -> Some x) p) <|> return None ) let rec many (p: 'a parser): 'a list parser = let* a = zero_or_one p in @@ -68,8 +83,11 @@ let many1 (p: 'a parser): 'a list parser = (* BNF: - let_expr ::= let identifier = expr in expr - fun_expr ::= fun identifier -> expr + type_parameter ::= [a-zA-Z][a-zA-Z0-9]* + type_generic ::= ''' type_parameter + type_declare ::= identifier | identifier -> type_declare | (type_declare) -> type_declare + let_expr ::= let identifier (: type_declare)? = expr in expr + fun_expr ::= fun (identifier | ('(' identifier (: type_declare)? ')'))? -> expr if_expr ::= if expr then expr else expr factor ::= (expr) | identifier | number call_expr ::= factor | factor factor @@ -77,6 +95,8 @@ BNF: level2 ::= level2 * level1 | level2 / level1 | level2 % level1 | level1 level3 ::= level2 ^ level3 | level2 expr ::= let_expr | fun_expr | if_expr | level3 + type_alias ::= 'type' type_declare (type_generic)? = type_declare + top ::= expr *) type bin_op_type = @@ -109,8 +129,22 @@ let op2str (op: bin_op_type): string = type mono_op_type = | Neg -type let_expr_tree = Let of string * expr_tree * expr_tree -and fun_expr_tree = Fun of string * expr_tree +type type_tree = + | TypeIdentifier of string + | TypeArrow of type_tree * type_tree + +type let_expr_tree = { + (* // TODO: add Pattern Matching *) + name: string; + type_declare: type_tree option; + value_expr: expr_tree; + in_expr: expr_tree; +} +and fun_expr_tree = { + name: string; + type_declare: type_tree option; + body_expr: expr_tree; +} and if_expr_tree = If of expr_tree * expr_tree * expr_tree and call_expr_tree = Call of expr_tree * expr_tree and expr_tree = @@ -123,42 +157,127 @@ and expr_tree = | Identifier of string | Number of int +let typeTree2str (t: type_tree): string = + let rec aux t = + match t with + | TypeIdentifier id -> id + | TypeArrow (t1, t2) -> Printf.sprintf "(%s -> %s)" (aux t1) (aux t2) in + aux t + let expr2str (e: expr_tree): string = let tab n = String.make (n * 2) ' ' in let rec aux e depth = match e with - | LetExpr (Let (id, e1, e2)) -> Printf.sprintf "let %s = %s in\n%s%s" id (aux e1 depth) (tab depth) (aux e2 (depth+1)) - | FunExpr (Fun (id, e)) -> Printf.sprintf "fun %s ->\n%s%s" id (tab depth) (aux e (depth+1)) - | IfExpr (If (e1, e2, e3)) -> Printf.sprintf "if %s then\n%s%selse\n%s%s" (aux e1 depth) (tab depth) (aux e2 depth) (tab depth) (aux e3 depth) - | CallExpr (Call (e1, e2)) -> Printf.sprintf "%s %s" (aux e1 depth) (aux e2 depth) + | LetExpr ({ + name = id; + value_expr = e1; + in_expr = e2; + type_declare = td; + }) -> + let type_declare_str = match td with + | Some t -> Printf.sprintf ": %s" (typeTree2str t) + | None -> "" in + Printf.sprintf "let %s%s = %s in\n%s%s" id + type_declare_str (aux e1 depth) (tab depth) (aux e2 (depth+1)) + | FunExpr ({ + name = id; + body_expr = e; + type_declare = td; + }) -> + let arg_str = match td with + | Some t -> Printf.sprintf "(%s: %s)" id (typeTree2str t) + | None -> id in + Printf.sprintf "fun %s ->\n%s%s" arg_str (tab depth) (aux e (depth+1)) + | IfExpr (If (e1, e2, e3)) -> Printf.sprintf "if %s then %s else %s" (aux e1 depth) (aux e2 depth) (aux e3 depth) + | CallExpr (Call (e1, e2)) -> Printf.sprintf "%s(%s)" (aux e1 depth) (aux e2 depth) | BinOpExpr (op, e1, e2) -> Printf.sprintf "%s %s %s" (aux e1 depth) (op2str op) (aux e2 depth) | MonoOpExpr (op, e) -> Printf.sprintf "%s %s" (op2str op) (aux e depth) | Identifier id -> id | Number n -> string_of_int n in aux e 0 +let rec parse_type_declare (): type_tree parser = + let parse_simple_type () = + let* tt = peek_token in + match tt.token_type with + | Token.Identifier x -> + let* _ = next_token in + return (TypeIdentifier x) + | Token.LParen -> + let* _ = match_token Token.LParen in + let* t = parse_type_declare() in + let* _ = match_token Token.RParen in + return t + | _ -> stop + in + let* base = parse_simple_type() in + let* lookahead = peek_token in + match lookahead.token_type with + | Token.Arrow -> + let* _ = next_token in + (* // TODO: add error handling for invalid type declaration *) + let* t = parse_type_declare() in + return (TypeArrow (base, t)) + | _ -> return base + +let parse_type_declare_with_colon (): type_tree option parser = + let* tt = zero_or_one (match_token Token.Colon) in + begin match tt with + | Some _ -> + let* t = zero_or_one (parse_type_declare()) in + begin match t with + | Some(t) -> return (Some t) + | _ -> let* _ = (push_error "invalid type declare") in return None + end + | None -> return None + end + let rec parse_let_expr (): let_expr_tree parser = let* _ = match_token ( Token.Let) in let* tt = next_token in match tt.token_type with Token.Identifier(x) -> let id = x in + let* type_declare = parse_type_declare_with_colon() in + let* _ = eat_until (fun x -> x.token_type = Token.Equal) in let* _ = match_token Token.Equal in let* e1 = expr() in let* _ = match_token (Token.In) in let* e2 = expr() in - return (Let (id, e1, e2)) + return ({ + name = id; + value_expr = e1; + in_expr = e2; + type_declare = type_declare + }) | _ -> stop and parse_fun_expr (): fun_expr_tree parser = let* _ = match_token (Token.Fun) in let* tt = next_token in - match tt.token_type with + begin match tt.token_type with Token.Identifier(x) -> let id = x in let* _ = match_token Token.Arrow in let* e = expr() in - return (Fun (id, e)) + return ({ + name = id; + body_expr = e; + type_declare = None + }) + | Token.LParen -> + let* id = match_identifier in + let* type_declare = parse_type_declare_with_colon() in + let* _ = eat_until (fun x -> x.token_type = Token.RParen) in + let* _ = match_token Token.RParen in + let* _ = match_token Token.Arrow in + let* e = expr() in + return ({ + name = id; + body_expr = e; + type_declare = type_declare + }) | _ -> stop + end and parse_if_expr (): if_expr_tree parser = let* _ = match_token (Token.If) in let* e1 = expr() in @@ -255,5 +374,47 @@ let get_expr_tree_from_tokens (tokens: (Token.t * Lexer.lexer_context) Seq.t): e let%test "test get_expr_tree_from_tokens 1" = let tokens = Lexer.lex_tokens_seq "let x = 1 in\n x" in match get_expr_tree_from_tokens tokens with - | Some e -> expr2str e = "let x = 1 in\n x" + | Some e -> expr2str e = "let x = 1 in\nx" | None -> false + +let%test "test get_expr_tree_from_tokens 2" = + let tokens = Lexer.lex_tokens_seq "fun x -> x" in + match get_expr_tree_from_tokens tokens with + | Some e -> expr2str e = "fun x ->\nx" + | None -> false + +let%test "test get_expr_tree_from_tokens 3" = + let tokens = Lexer.lex_tokens_seq "if 1 then 2 else 3" in + match get_expr_tree_from_tokens tokens with + | Some e -> expr2str e = "if 1 then 2 else 3" + | None -> false + +let%test "test get_expr_tree_from_tokens 4" = + let tokens = Lexer.lex_tokens_seq "1 + 2 * 3" in + match get_expr_tree_from_tokens tokens with + | Some e -> expr2str e = "1 + 2 * 3" + | None -> false + +let%test "test get_expr_tree_from_tokens 5" = + let tokens = Lexer.lex_tokens_seq "x 1 2" in + match get_expr_tree_from_tokens tokens with + | Some e -> expr2str e = "x(1)(2)" + | None -> false + +let%test "test get_expr_tree_from_tokens 6 with type" = + let tokens = Lexer.lex_tokens_seq "let x: int = 1 in\n x" in + match get_expr_tree_from_tokens tokens with + | Some e -> expr2str e = "let x: int = 1 in\nx" + | None -> false + +let%test "test get_expr_tree_from_tokens 7 with type" = + let tokens = Lexer.lex_tokens_seq "fun (x: int) -> x" in + match get_expr_tree_from_tokens tokens with + | Some e -> expr2str e = "fun (x: int) ->\nx" + | None -> false + +let%test "test get_expr_tree_from_tokens 8" = + let tokens = Lexer.lex_tokens_seq "fun (x) -> x" in + match get_expr_tree_from_tokens tokens with + | Some e -> expr2str e = "fun x ->\nx" + | None -> false \ No newline at end of file