monoid/small-set-of-ml
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat: add type declaration support in let and fun expressions

Browse source
This commit is contained in:
monoid 2025-02-16 19:47:12 +09:00
parent 9569b20542
commit 1e172f80ef
3 changed files with 187 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
lib/eval.ml
View file

@ -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

5
lib/lexer.ml
View file

@ -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
View file

@ -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