feat: add type declaration support in let and fun expressions
This commit is contained in:
parent
9569b20542
commit
1e172f80ef
3 changed files with 187 additions and 25 deletions
12
lib/eval.ml
12
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
| '-' ->
|
||||
|
|
|
|||
195
lib/parser.ml
195
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
|
||||
Loading…
Add table
Reference in a new issue