From ed4f49311c094b3ee4d0fe79d703ab317fc6f387 Mon Sep 17 00:00:00 2001 From: Emin Arslan Date: Mon, 2 Feb 2026 20:32:15 +0300 Subject: [PATCH] syntactic_ast: unwrapped the central GADT into several related types. core_ast: related to the above, reorganized core_ast to use the new syntactic ast --- lib/compiler/core_ast.ml | 37 +++++------ lib/compiler/syntactic_ast.ml | 115 +++++++++++++++------------------ lib/compiler/syntactic_ast.mli | 46 ------------- 3 files changed, 71 insertions(+), 127 deletions(-) delete mode 100644 lib/compiler/syntactic_ast.mli diff --git a/lib/compiler/core_ast.ml b/lib/compiler/core_ast.ml index 2529f78..b4f22f8 100644 --- a/lib/compiler/core_ast.ml +++ b/lib/compiler/core_ast.ml @@ -28,12 +28,10 @@ type top_level = -let rec pair_of_def : Syntactic_ast.definition Syntactic_ast.t -> string * expression = function - | Syntactic_ast.Define (s, e) -> (s, of_expr e) -and pair_of_binding = function - | Syntactic_ast.LetBinding (s, e) -> (s, of_expr e) -and pair_of_clause = function - | Syntactic_ast.CondClause (e1, e2) -> (of_expr e1, of_expr e2) +let rec pair_of_def : Syntactic_ast.def -> string * expression = + fun (s, e) -> (s, of_expr e) +and pair_of_binding (s, e) = (s, of_expr e) +and pair_of_clause (e1, e2) = (of_expr e1, of_expr e2) and make_lambda args body = match args with @@ -65,11 +63,11 @@ and make_let bs body = of expressions. The definitions behave exactly as a letrec, so it makes sense to convert the body into a normal letrec. *) -and of_body : Syntactic_ast.body Syntactic_ast.t -> expression = function - | Body ([], exprs) -> +and of_body : Syntactic_ast.body -> expression = function + | ([], exprs) -> let exprs = List.map of_expr exprs in Begin exprs - | Body (defs, exprs) -> + | (defs, exprs) -> let exprs = List.map of_expr exprs in let defs = List.map pair_of_def defs in let b = Begin exprs in @@ -77,16 +75,19 @@ and of_body : Syntactic_ast.body Syntactic_ast.t -> expression = function (* TODO: currently this ignores the "optional" part of the lambda list, fix this *) -and of_ll : Syntactic_ast.lambda_list Syntactic_ast.t -> string list = function - | LambdaList (sl, _) -> sl +and of_ll : Syntactic_ast.lambda_list -> string list = function + | (sl, _) -> sl -and of_expr : Syntactic_ast.expression Syntactic_ast.t -> expression = function - | LitNil -> Literal Nil - | LitInt x -> Literal (Int x) - | LitDouble x -> Literal (Double x) - | LitString x -> Literal (String x) +and of_literal : Syntactic_ast.literal -> literal = function + | LitInt x -> Int x + | LitDouble x -> Double x + | LitString x -> String x + | LitCons (a, b) -> Cons (of_literal a, of_literal b) + | LitNil -> Nil + +and of_expr : Syntactic_ast.expr -> expression = function + | Literal l -> Literal (of_literal l) | Var x -> Var x - | QuotedList _ -> failwith "TODO: rethink how quoted lists should work, the current definition makes no sense." | Lambda (ll, b) -> make_lambda (of_ll ll) b | Let (bindings, b) -> make_let bindings b | LetRec (bindings, b) -> LetRec (List.map pair_of_binding bindings, of_body b) @@ -102,7 +103,7 @@ and of_expr : Syntactic_ast.expression Syntactic_ast.t -> expression = function and of_syntactic : Syntactic_ast.top_level -> top_level = function - | Def (Define (s, e)) -> Define (s, of_expr e) + | Def (s, e) -> Define (s, of_expr e) | Exp (e) -> Expr (of_expr e) | _ -> . diff --git a/lib/compiler/syntactic_ast.ml b/lib/compiler/syntactic_ast.ml index b7eb4a3..ea4460b 100644 --- a/lib/compiler/syntactic_ast.ml +++ b/lib/compiler/syntactic_ast.ml @@ -1,48 +1,35 @@ (* The entire point of this module is to transform a given sexpr tree into - an intermediary typed AST. + an intermediary AST that directly represents the grammar. *) -type symbol = string +(* Literals *) +type literal = + | LitInt of int + | LitDouble of float + | LitString of string + | LitCons of literal * literal + | LitNil -(* These are just used for the GADT *) -type expression = Phantom_expr -type definition = Phantom_def -type clause = Phantom_clause (* for cond *) -type binding = Phantom_binding(* for let *) -type lambda_list = Phantom_lambda_list -type body = Phantom_body +type lambda_list = string list * string option -type _ t = - (* Literals *) - | LitInt : int -> expression t - | LitDouble : float -> expression t - | LitString : string -> expression t - | LitNil : expression t - | QuotedList : expression t list * expression t option -> expression t - - | Body : definition t list * expression t list -> body t - | LambdaList : symbol list * symbol option -> lambda_list t - | Lambda : lambda_list t * body t -> expression t - | Define : symbol * expression t -> definition t - - | LetBinding : symbol * expression t -> binding t - | Let : binding t list * body t -> expression t - | LetRec : binding t list * body t -> expression t - - | CondClause : expression t * expression t -> clause t - | Cond : clause t list -> expression t - - | If : expression t * expression t * expression t -> expression t - | Set : string * expression t -> expression t - - | Var : symbol -> expression t - | Apply : expression t * expression t list -> expression t +type expr = + | Literal of literal + | Lambda of lambda_list * body + | Let of (string * expr) list * body + | LetRec of (string * expr) list * body + | Cond of (expr * expr) list + | If of expr * expr * expr + | Set of string * expr + | Var of string + | Apply of expr * expr list +and def = string * expr +and body = def list * expr list (* On the top-level we only allow definitions and expressions *) type top_level = - | Def of definition t - | Exp of expression t + | Def of def + | Exp of expr (* we use result here to make things nicer *) @@ -57,7 +44,7 @@ let traverse f l = let map = List.map -let exp x = Ok (Exp x) + let unwrap_exp = function | Ok (Exp x) -> Ok x | Error _ as e -> e @@ -67,6 +54,8 @@ let unwrap_def x = match x with | Def d -> Ok d | _ -> Error "Expression found in Definition context" +let exp x = Ok (Exp x) +let lit x = Ok (Exp (Literal x)) let def x = Ok (Def x) @@ -109,10 +98,10 @@ let rec list_of_sexpr = function let parse_lambda_list cons = let rec aux acc = function | LCons (LSymbol a, LSymbol b) -> - Ok (LambdaList (List.rev (a :: acc), Some b)) + Ok (List.rev (a :: acc), Some b) | LCons (LSymbol a, rest) -> aux (a :: acc) rest - | LNil -> Ok (LambdaList (List.rev acc, None)) + | LNil -> Ok (List.rev acc, None) | _ -> Error "Improper lambda list." in aux [] cons @@ -139,7 +128,7 @@ let rec parse_body body = *) let* defs = traverse (Fun.compose unwrap_def transform) defs in let* exprs = traverse (Fun.compose unwrap_exp transform) exprs in - Ok (Body (defs, exprs)) + Ok (defs, exprs) and builtin_define cons = let* second = sexpr_cadr cons in @@ -148,13 +137,13 @@ and builtin_define cons = (* regular, symbol/variable definition *) let* third = sexpr_caddr cons in let* value = unwrap_exp (transform third) in - def (Define (sym, value)) + Ok (Def (sym, value)) | LCons (LSymbol sym, ll) -> (* function definition, we treat this as a define + lambda *) let* lambda_list = parse_lambda_list ll in let* body = sexpr_cddr cons in let* body = parse_body body in - def (Define (sym, Lambda (lambda_list, body))) + Ok (Def (sym, Lambda (lambda_list, body))) | _ -> Error "invalid definition!" and builtin_lambda cons = @@ -170,7 +159,7 @@ and parse_bindings cons = let* sym = expect_sym sym in let* expr = sexpr_cadr cons in let* expr = unwrap_exp (transform expr) in - Ok (LetBinding (sym, expr)) + Ok (sym, expr) in let* l = list_of_sexpr cons in traverse parse_one l @@ -188,7 +177,7 @@ and parse_clauses cons = let* test = unwrap_exp (transform test) in let* expr = sexpr_cadr cons in let* expr = unwrap_exp (transform expr) in - Ok (CondClause (test, expr)) + Ok (test, expr) in let* l = list_of_sexpr cons in traverse parse_one l @@ -239,14 +228,14 @@ and builtin_symbol = function | _ -> Error "Invalid function application!") and transform : lisp_ast -> (top_level, string) result = function - | LInt x -> exp (LitInt x) - | LDouble x -> exp (LitDouble x) - | LString x -> exp (LitString x) + | LInt x -> lit (LitInt x) + | LDouble x -> lit (LitDouble x) + | LString x -> lit (LitString x) (* NOTE: not all symbols are automatically Variable expressions, Some must be further parsed (such as inside a definition) *) | LSymbol x -> exp (Var x) - | LNil -> exp (LitNil) + | LNil -> lit (LitNil) | LCons (LSymbol s, _) as cons -> (builtin_symbol s) cons | LCons (f, args) -> apply f args @@ -257,36 +246,36 @@ let make (expr : Parser.Ast.lisp_ast) : (top_level, string) result = (* Printing, for debug purposes *) let pf = Printf.sprintf -let rec print_as_list l = - let l = map print_expr l in - String.concat " " l -and print_lambda_list = function - | LambdaList (strs, None) -> ("(" ^ (String.concat " " strs) ^ ")") - | LambdaList (strs, Some x) -> ("(" ^ (String.concat " " strs) ^ " . " ^ x ^ ")") +let rec print_lambda_list = function + | (strs, None) -> ("(" ^ (String.concat " " strs) ^ ")") + | (strs, Some x) -> ("(" ^ (String.concat " " strs) ^ " . " ^ x ^ ")") and print_let_binding x = - let (LetBinding (s, expr)) = x in + let (s, expr) = x in pf "(%s %s)" s (print_expr expr) and print_bindings l = ("(" ^ (String.concat "\n" (map print_let_binding l)) ^ ")") and print_clause x = - let (CondClause (test, expr)) = x in + let (test, expr) = x in pf "(%s %s)" (print_expr test) (print_expr expr) and print_clauses l = (String.concat "\n" (map print_clause l)) and print_def = function - | Define (s, expr) -> + | (s, expr) -> pf "(define %s %s)" s (print_expr expr) and print_defs l = String.concat "\n" (map print_def l) -and print_expr = function + +and print_literal = function | LitDouble x -> pf "%f" x | LitInt x -> pf "%d" x | LitString x -> pf "\"%s\"" x | LitNil -> pf "nil" - | QuotedList (exprs, None) -> "(" ^ (print_as_list exprs) ^ ")" - | QuotedList (exprs, Some ex) -> "(" ^ (print_as_list exprs) ^ " . " ^ (print_expr ex) ^ ")" - | Lambda (ll, Body (defs, exprs)) -> + | LitCons (a, b) -> pf "(%s . %s)" (print_literal a) (print_literal b) + +and print_expr = function + | Literal l -> print_literal l + | Lambda (ll, (defs, exprs)) -> pf "(lambda %s ; DEFINITIONS %s @@ -295,7 +284,7 @@ and print_expr = function (print_lambda_list ll) (String.concat "\n" (map print_def defs)) (String.concat "\n" (map print_expr exprs)) - | Let (binds, Body (defs, exprs)) -> + | Let (binds, (defs, exprs)) -> pf "(let ; BINDINGS %s @@ -306,7 +295,7 @@ and print_expr = function (print_bindings binds) (print_defs defs) (print_exprs exprs) - | LetRec (binds, Body (defs, exprs)) -> + | LetRec (binds, (defs, exprs)) -> pf "(letrec ; BINDINGS %s diff --git a/lib/compiler/syntactic_ast.mli b/lib/compiler/syntactic_ast.mli deleted file mode 100644 index 45c24c3..0000000 --- a/lib/compiler/syntactic_ast.mli +++ /dev/null @@ -1,46 +0,0 @@ -type symbol = string - -(* These are just used for the GADT *) -type expression = Phantom_expr -type definition = Phantom_def -type clause = Phantom_clause (* for cond *) -type binding = Phantom_binding(* for let *) -type lambda_list = Phantom_lambda_list -type body = Phantom_body - -type _ t = - (* Literals *) - | LitInt : int -> expression t - | LitDouble : float -> expression t - | LitString : string -> expression t - | LitNil : expression t - | QuotedList : expression t list * expression t option -> expression t - - | Body : definition t list * expression t list -> body t - | LambdaList : symbol list * symbol option -> lambda_list t - | Lambda : lambda_list t * body t -> expression t - | Define : symbol * expression t -> definition t - - | LetBinding : symbol * expression t -> binding t - | Let : binding t list * body t -> expression t - | LetRec : binding t list * body t -> expression t - - | CondClause : expression t * expression t -> clause t - | Cond : clause t list -> expression t - - | If : expression t * expression t * expression t -> expression t - | Set : string * expression t -> expression t - - | Var : symbol -> expression t - | Apply : expression t * expression t list -> expression t - -type top_level = - | Def of definition t - | Exp of expression t - - -val make : Parser.Ast.lisp_ast -> (top_level, string) result - -val print_def : definition t -> string -val print_expr : expression t -> string -val print : top_level -> string