Welcome to the Tsonnet series!
If you're not following the series so far, you can check out how it all started in the first post of the series.
In the previous post, I added comprehensive testing for object interpretation to prevent reference leaks:
This will be short and sweet post, so let's get to it.
When I first wrote the type checking function, I made an innocent mistake by having the environment parameter in a different order in the translate function compared to the interpreter. It's not a big deal, but consistency is important!
diff --git a/lib/type.ml b/lib/type.ml
index 99f11cc..1ece085 100644
--- a/lib/type.ml
+++ b/lib/type.ml
@@ -111,7 +111,7 @@ and check_object_field_chain_for_cycles venv (pos, scope, exprs) seen =
(ok ())
exprs
-let rec translate expr venv =
+let rec translate venv expr =
match expr with
| Unit -> ok (venv, Tunit)
| Null _ -> ok (venv, Tnull)
@@ -122,7 +122,7 @@ let rec translate expr venv =
Env.find_var varname venv
~succ:(fun venv ty ->
match ty with
- | Lazy expr -> translate expr venv
+ | Lazy expr -> translate venv expr
| _ -> ok (venv, ty)
)
~err:(Error.error_at pos)
@@ -168,26 +168,26 @@ let rec translate expr venv =
in ok (venv', Tunit)
| Seq exprs ->
List.fold_left
- (fun acc expr -> acc >>= fun (venv, _) -> translate expr venv)
+ (fun acc expr -> acc >>= fun (venv, _) -> translate venv expr)
(ok (venv, Tunit))
exprs
| BinOp (pos, op, e1, e2) ->
- (let* (venv', e1') = translate e1 venv in
- let* (venv'', e2') = translate e2 venv' in
+ (let* (venv', e1') = translate venv e1 in
+ let* (venv'', e2') = translate venv' e2 in
match op, e1', e2' with
| _, Tnumber, Tnumber -> ok (venv'', Tnumber)
| Add, _, Tstring | Add, Tstring, _ -> ok (venv'', Tstring)
| _ -> Error.trace "Invalid binary operation" pos >>= error
)
| UnaryOp (pos, op, expr) ->
- (let* (venv', expr') = translate expr venv in
+ (let* (venv', expr') = translate venv expr in
match op, expr' with
| Plus, Tnumber | Minus, Tnumber | BitwiseNot, Tnumber -> ok (venv', Tnumber)
| Not, Tbool | BitwiseNot, Tbool -> ok (venv', Tbool)
| _ -> Error.trace "Invalid unary operation" pos >>= error
)
| IndexedExpr (pos, varname, index_expr) ->
- (let* (venv', index_expr') = translate index_expr venv in
+ (let* (venv', index_expr') = translate venv index_expr in
match index_expr' with
| Tnumber ->
Env.find_var varname venv'
@@ -195,7 +195,7 @@ let rec translate expr venv =
match expr' with
| (Tarray _) as ty -> ok (venv', ty)
| Tstring as ty -> ok (venv', ty)
- | Lazy expr -> translate expr venv
+ | Lazy expr -> translate venv expr
| ty -> error (to_string ty ^ " is a non indexable value")
)
~err:(Error.error_at pos)
@@ -205,7 +205,7 @@ let rec translate expr venv =
error ("Invalid type " ^ string_of_type expr')
and translate_lazy venv = function
- | Lazy expr -> translate expr venv
+ | Lazy expr -> translate venv expr
| ty -> error ("Invalid type " ^ to_string ty)
and translate_object venv pos entries =
@@ -222,7 +222,7 @@ and translate_object venv pos entries =
let* venv = result in
match entry with
| ObjectExpr expr ->
- let* (venv', _) = translate expr venv in (ok venv')
+ let* (venv', _) = translate venv expr in (ok venv')
| ObjectField (attr, expr) ->
ok (Env.add_obj_field attr (Lazy expr) obj_id venv)
)
@@ -292,7 +292,7 @@ and translate_object_field_access venv pos scope chain_exprs =
~succ:translate_lazy
~err:(Error.error_at pos)
| IndexedExpr (pos, field, index_expr) ->
- let* (venv', index_expr_ty) = translate index_expr venv in
+ let* (venv', index_expr_ty) = translate venv index_expr in
let* () =
match index_expr_ty with
| Tnumber | Tstring -> ok ()
@@ -317,7 +317,7 @@ and translate_object_field_access venv pos scope chain_exprs =
let check expr =
Scope.validate expr
- >>= fun _ -> translate expr Env.empty
+ >>= fun _ -> translate Env.empty expr
>>= fun _ ->
Env.Id.reset ();
ok expr
Yeah, I know what you're thinking: "Is this really worth a whole post?". We can argue that this is not a big deal, and in theory, it isn't, but in practice it's much more comfortable to work in a codebase where you get used to the pattern, and even better when they are replicated across multiple modules and functions. It just feels natural! Our brains just stop fighting the code.
Consistency, consistency, consistency!
Speaking of patterns -- this parameter ordering change is actually a small step toward a bigger goal. Eventually, I want to enforce better type checking in-between compiler phases: parsing -> scope validation -> type checking -> interpretation. As of now, we work with the same AST across multiple phases, but it would be nice to have intermediate representations between each step. This could help removing duplicated checks already present, and making invalid states unrepresentable.
But that's a story for another day. Before doing such big refactoring, there's something even more mundane that helps moving towards this goal: extracting error messages.
lib/error.ml:
module Msg = struct
(* Shared operation messages *)
let self_out_of_scope = "Can't use self outside of an object"
let no_toplevel_object = "No top-level object found"
let invalid_binary_op = "Invalid binary operation"
let invalid_unary_op = "Invalid unary operation"
let must_be_object = "Must be an object"
(* Type checker messages *)
let type_cyclic_reference varname = "Cyclic reference found for " ^ varname
let type_non_indexable_value ty = ty ^ " is a non indexable value"
let type_expected_integer_index ty = "Expected Integer index, got " ^ ty
let type_invalid_expr expr = "Invalid type " ^ expr
let type_non_indexable_type ty = ty ^ " is a non-indexable type"
let type_non_indexable_field field = field ^ " is a non-indexable value"
let type_invalid_lookup_key expr = "Invalid object lookup key: " ^ expr
(* Interpreter messages *)
let interp_invalid_concat = "Invalid string concatenation operation"
let interp_invalid_lookup = "Invalid object lookup"
let interp_cannot_interpret expr = Printf.sprintf "Expression %s cannot be interpreted" expr
end
See what I mean with the shared operation messages?! Those invalid_binary_op and invalid_unary_op strings appear in both the type checker and interpreter -- operations that should really only happen once, in a single compilation phase.
Now I can replace the hard-coded error messages everywhere:
diff --git a/lib/interpreter.ml b/lib/interpreter.ml
index fe7f1a7..77b3ac2 100644
--- a/lib/interpreter.ml
+++ b/lib/interpreter.ml
@@ -30,7 +30,7 @@ let interpret_concat_op env (e1 : expr) (e2 : expr) : (expr, string) result =
| val1, String (_, s2) ->
let* s1 = Json.expr_to_string (env, val1) in ok (String (dummy_pos, s1^s2))
| _ ->
- error "Invalid string concatenation operation"
+ error Error.Msg.interp_invalid_concat
let interpret_unary_op (op: unary_op) (evaluated_expr: expr) =
match op, evaluated_expr with
@@ -39,7 +39,7 @@ let interpret_unary_op (op: unary_op) (evaluated_expr: expr) =
| Minus, Number (pos, Float f) -> ok (Number (pos, Float (-. f)))
| Not, (Bool (pos, b)) -> ok (Bool (pos, not b))
| BitwiseNot, Number (pos, Int i) -> ok (Number (pos, Int (lnot i)))
- | _ -> error "Invalid unary operation"
+ | _ -> error Error.Msg.invalid_unary_op
(** [interpret expr] interprets and reduce the intermediate AST [expr] into a result AST. *)
let rec interpret env expr =
@@ -63,7 +63,7 @@ let rec interpret env expr =
| _, Number (pos, v1), Number (_, v2) ->
ok (env2, Number (pos, interpret_arith_op op v1 v2))
| _ ->
- Error.trace "Invalid binary operation" pos >>= error
+ Error.trace Error.Msg.invalid_binary_op pos >>= error
)
| UnaryOp (pos, op, expr) ->
let* (env', expr') = interpret env expr in
@@ -91,7 +91,7 @@ let rec interpret env expr =
)
~err:(Error.error_at pos)
| expr ->
- error (Printf.sprintf "Expression %s cannot be interpreted" (string_of_type expr))
+ error (Error.Msg.interp_cannot_interpret (string_of_type expr))
and interpret_array env (pos, exprs) =
let* (env', evaluated_exprs) = List.fold_left
@@ -159,8 +159,8 @@ and interpret_object_field_access env (pos, scope, chain_exprs) =
| _ ->
Error.error_at pos
(match scope with
- | Self -> Scope.self_out_of_scope
- | TopLevel -> Scope.no_toplevel_object)
+ | Self -> Error.Msg.self_out_of_scope
+ | TopLevel -> Error.Msg.no_toplevel_object)
in
List.fold_left
(fun acc field_expr ->
@@ -169,7 +169,7 @@ and interpret_object_field_access env (pos, scope, chain_exprs) =
match prev_expr with
| ObjectPtr (obj_id, _) -> ok obj_id
| RuntimeObject (_, obj_id, _) -> ok obj_id
- | _ -> Error.error_at pos "Must be an object"
+ | _ -> Error.error_at pos Error.Msg.must_be_object
in
match field_expr with
@@ -191,7 +191,7 @@ and interpret_object_field_access env (pos, scope, chain_exprs) =
~ok:(fun e -> interpret env' e)
~error:(Error.error_at pos)
| _e ->
- Error.error_at pos "Invalid object lookup"
+ Error.error_at pos Error.Msg.interp_invalid_lookup
)
(ok (env, obj))
chain_exprs
diff --git a/lib/scope.ml b/lib/scope.ml
index d61a9c9..8846f39 100644
--- a/lib/scope.ml
+++ b/lib/scope.ml
@@ -12,9 +12,6 @@ type context = {
current_locals: string list;
}
-let self_out_of_scope = "Can't use self outside of an object"
-let no_toplevel_object = "No top-level object found"
-
let empty_context = {
in_object = false;
object_depth = 0;
@@ -61,8 +58,8 @@ let rec _validate expr context =
and validate_ident pos varname context =
match (varname, context.in_object) with
- | ("self", false) -> Error.trace self_out_of_scope pos >>= error
- | ("$", false) -> Error.trace no_toplevel_object pos >>= error
+ | ("self", false) -> Error.trace Error.Msg.self_out_of_scope pos >>= error
+ | ("$", false) -> Error.trace Error.Msg.no_toplevel_object pos >>= error
| _ -> ok ()
and validate_expression_list exprs context =
@@ -109,8 +106,8 @@ and validate_object_field_access pos scope context =
if not context.in_object
then
let with_error_msg = match scope with
- | Self -> self_out_of_scope
- | TopLevel -> no_toplevel_object
+ | Self -> Error.Msg.self_out_of_scope
+ | TopLevel -> Error.Msg.no_toplevel_object
in
Error.trace with_error_msg pos >>= error
else ok ()
diff --git a/lib/type.ml b/lib/type.ml
index 1ece085..f1f30af 100644
--- a/lib/type.ml
+++ b/lib/type.ml
@@ -56,7 +56,7 @@ let rec to_string = function
let rec check_cyclic_refs venv varname seen pos =
if List.mem varname seen
then
- Error.trace ("Cyclic reference found for " ^ varname) pos >>= error
+ Error.trace (Error.Msg.type_cyclic_reference varname) pos >>= error
else
match Env.find_opt varname venv with
| Some (Lazy expr) -> check_expr_for_cycles venv expr (varname :: seen)
@@ -177,14 +177,14 @@ let rec translate venv expr =
match op, e1', e2' with
| _, Tnumber, Tnumber -> ok (venv'', Tnumber)
| Add, _, Tstring | Add, Tstring, _ -> ok (venv'', Tstring)
- | _ -> Error.trace "Invalid binary operation" pos >>= error
+ | _ -> Error.trace Error.Msg.invalid_binary_op pos >>= error
)
| UnaryOp (pos, op, expr) ->
(let* (venv', expr') = translate venv expr in
match op, expr' with
| Plus, Tnumber | Minus, Tnumber | BitwiseNot, Tnumber -> ok (venv', Tnumber)
| Not, Tbool | BitwiseNot, Tbool -> ok (venv', Tbool)
- | _ -> Error.trace "Invalid unary operation" pos >>= error
+ | _ -> Error.trace Error.Msg.invalid_unary_op pos >>= error
)
| IndexedExpr (pos, varname, index_expr) ->
(let* (venv', index_expr') = translate venv index_expr in
@@ -196,17 +196,17 @@ let rec translate venv expr =
| (Tarray _) as ty -> ok (venv', ty)
| Tstring as ty -> ok (venv', ty)
| Lazy expr -> translate venv expr
- | ty -> error (to_string ty ^ " is a non indexable value")
+ | ty -> error (Error.Msg.type_non_indexable_value (to_string ty))
)
~err:(Error.error_at pos)
- | ty -> Error.trace ("Expected Integer index, got " ^ to_string ty) pos >>= error
+ | ty -> Error.trace (Error.Msg.type_expected_integer_index (to_string ty)) pos >>= error
)
| expr' ->
- error ("Invalid type " ^ string_of_type expr')
+ error (Error.Msg.type_invalid_expr (string_of_type expr'))
and translate_lazy venv = function
| Lazy expr -> translate venv expr
- | ty -> error ("Invalid type " ^ to_string ty)
+ | ty -> error (Error.Msg.type_invalid_expr (to_string ty))
and translate_object venv pos entries =
let* obj_id = Env.Id.generate () in
@@ -270,8 +270,8 @@ and translate_object_field_access venv pos scope chain_exprs =
| _ ->
Error.error_at pos
(match scope with
- | Self -> Scope.self_out_of_scope
- | TopLevel -> Scope.no_toplevel_object)
+ | Self -> Error.Msg.self_out_of_scope
+ | TopLevel -> Error.Msg.no_toplevel_object)
in
List.fold_left
@@ -282,7 +282,7 @@ and translate_object_field_access venv pos scope chain_exprs =
match prev_ty with
| TobjectPtr (obj_id, _) -> ok obj_id
| TruntimeObject (obj_id, _) -> ok obj_id
- | _ -> Error.error_at pos "Must be an object"
+ | _ -> Error.error_at pos Error.Msg.must_be_object
in
match field_expr with
@@ -296,7 +296,7 @@ and translate_object_field_access venv pos scope chain_exprs =
let* () =
match index_expr_ty with
| Tnumber | Tstring -> ok ()
- | ty -> Error.error_at pos (to_string ty ^ " is a non-indexable type")
+ | ty -> Error.error_at pos (Error.Msg.type_non_indexable_type (to_string ty))
in
let* obj_id = get_obj_id in
let* (venv', ty) =
@@ -307,10 +307,10 @@ and translate_object_field_access venv pos scope chain_exprs =
(match ty with
| (Tarray _) as array_ty -> ok (venv', array_ty)
| Tstring as ty -> ok (venv', ty)
- | _ -> Error.error_at pos (field ^ " is a non-indexable value")
+ | _ -> Error.error_at pos (Error.Msg.type_non_indexable_field field)
)
| _ ->
- Error.error_at pos ("Invalid object lookup key: " ^ string_of_type field_expr)
+ Error.error_at pos (Error.Msg.type_invalid_lookup_key (string_of_type field_expr))
)
(ok (venv, obj))
chain_exprs
Conclusion
That's all for today! Nothing revolutionary, but these little improvements are making the codebase easier to navigate.
Now let me write down the ideas for a future refactoring.
The entire diff can be seen here.
Thanks for reading Bit Maybe Wise! Subscribe to watch me reorganize function parameters like I'm Marie Kondo-ing the compiler -- does it spark consistency? Then it stays!
Top comments (0)