@@ -150,6 +150,16 @@ let rec eval (env : env) (expr : expr) : value result =
150150 Ok (VArray (Array. of_list vals))
151151
152152 | ExprRecord er ->
153+ (* Start with spread base if present *)
154+ let * base_fields = match er.er_spread with
155+ | Some spread_expr ->
156+ let * spread_val = eval env spread_expr in
157+ begin match spread_val with
158+ | VRecord fields -> Ok fields
159+ | _ -> Error (TypeMismatch " Spread operator requires a record" )
160+ end
161+ | None -> Ok []
162+ in
153163 let * field_vals = List. fold_right (fun (id , expr_opt ) acc ->
154164 let * fields = acc in
155165 match expr_opt with
@@ -161,7 +171,12 @@ let rec eval (env : env) (expr : expr) : value result =
161171 let * v = lookup_env id.name env in
162172 Ok ((id.name, v) :: fields)
163173 ) er.er_fields (Ok [] ) in
164- Ok (VRecord field_vals)
174+ (* Merge: explicit fields override spread fields *)
175+ let explicit_names = List. map fst field_vals in
176+ let remaining_base = List. filter (fun (n , _ ) ->
177+ not (List. mem n explicit_names)
178+ ) base_fields in
179+ Ok (VRecord (field_vals @ remaining_base))
165180
166181 | ExprField (base , field ) ->
167182 let * base_val = eval env base in
@@ -200,17 +215,110 @@ let rec eval (env : env) (expr : expr) : value result =
200215 let _ = type_id in (* Ignore type part for now *)
201216 Ok (VVariant (variant_id.name, None ))
202217
203- | ExprRowRestrict _ ->
204- Error (RuntimeError " Row restriction not supported at runtime" )
218+ | ExprRowRestrict (base , field ) ->
219+ let * base_val = eval env base in
220+ begin match base_val with
221+ | VRecord fields ->
222+ let filtered = List. filter (fun (n , _ ) -> n <> field.name) fields in
223+ Ok (VRecord filtered)
224+ | _ -> Error (TypeMismatch " Row restriction requires a record" )
225+ end
205226
206- | ExprHandle _ ->
207- Error (RuntimeError " Effect handlers not yet implemented" )
227+ | ExprHandle eh ->
228+ (* Evaluate the body expression. If it performs an effect via
229+ PerformEffect, we match against the handler arms.
230+ HandlerReturn arms match the normal return value.
231+ HandlerOp arms match performed effects. *)
232+ begin match eval env eh.eh_body with
233+ | Ok v ->
234+ (* Normal return — look for a HandlerReturn arm *)
235+ let return_arm = List. find_opt (fun arm ->
236+ match arm with HandlerReturn _ -> true | _ -> false
237+ ) eh.eh_handlers in
238+ begin match return_arm with
239+ | Some (HandlerReturn (pat , body )) ->
240+ let * bindings = match_pattern pat v in
241+ let env' = extend_env_list bindings env in
242+ eval env' body
243+ | _ -> Ok v (* No return handler — pass through *)
244+ end
245+ | Error (PerformEffect (op_name , args )) ->
246+ (* Effect performed — find matching HandlerOp arm *)
247+ let op_arm = List. find_opt (fun arm ->
248+ match arm with
249+ | HandlerOp (id , _ , _ ) -> id.name = op_name
250+ | _ -> false
251+ ) eh.eh_handlers in
252+ begin match op_arm with
253+ | Some (HandlerOp (_ , pats , body )) ->
254+ (* Bind effect arguments to handler parameters.
255+ The last parameter is conventionally the resume continuation,
256+ but for now we bind a simple identity closure. *)
257+ let arg_vals = match args with
258+ | [single] -> [single]
259+ | multiple -> [VTuple multiple]
260+ in
261+ let resume_fn = VBuiltin (" resume" , fun resume_args ->
262+ match resume_args with
263+ | [v] -> Ok v
264+ | _ -> Ok VUnit
265+ ) in
266+ let all_vals = arg_vals @ [resume_fn] in
267+ let bindings = List. fold_left2 (fun acc pat v ->
268+ match acc with
269+ | Ok bs ->
270+ begin match match_pattern pat v with
271+ | Ok new_bs -> Ok (new_bs @ bs)
272+ | Error e -> Error e
273+ end
274+ | Error e -> Error e
275+ ) (Ok [] ) pats (List. filteri (fun i _ -> i < List. length pats) all_vals) in
276+ let * bindings = bindings in
277+ let env' = extend_env_list bindings env in
278+ eval env' body
279+ | _ -> Error (RuntimeError (" Unhandled effect: " ^ op_name))
280+ end
281+ | Error e -> Error e
282+ end
208283
209- | ExprResume _ ->
210- Error (RuntimeError " Resume not yet implemented" )
284+ | ExprResume arg_opt ->
285+ (* Resume is only meaningful inside an effect handler. At the top
286+ level it's a no-op that returns the argument or unit. *)
287+ begin match arg_opt with
288+ | Some e -> eval env e
289+ | None -> Ok VUnit
290+ end
211291
212- | ExprTry _ ->
213- Error (RuntimeError " Try/catch not yet implemented" )
292+ | ExprTry et ->
293+ (* Evaluate the body block. If it returns an error, match against
294+ catch arms. Always run finally block if present. *)
295+ let body_result = eval_block env et.et_body in
296+ let catch_result = match body_result with
297+ | Ok v -> Ok v
298+ | Error (RuntimeError msg ) ->
299+ begin match et.et_catch with
300+ | Some arms ->
301+ (* Wrap the error as a variant for pattern matching *)
302+ let err_val = VVariant (" RuntimeError" , Some (VString msg)) in
303+ eval_match_arms env err_val arms
304+ | None -> Error (RuntimeError msg)
305+ end
306+ | Error (PatternMatchFailure) ->
307+ begin match et.et_catch with
308+ | Some arms ->
309+ let err_val = VVariant (" PatternMatchFailure" , None ) in
310+ eval_match_arms env err_val arms
311+ | None -> Error PatternMatchFailure
312+ end
313+ | Error e -> Error e
314+ in
315+ (* Run finally block if present (result is discarded) *)
316+ begin match et.et_finally with
317+ | Some finally_blk ->
318+ let _ = eval_block env finally_blk in
319+ catch_result
320+ | None -> catch_result
321+ end
214322
215323 | ExprUnsafe ops ->
216324 (* Evaluate unsafe operations - for now, just evaluate contained expressions *)
@@ -652,6 +760,79 @@ let create_initial_env () : env =
652760 | _ -> Error (TypeMismatch " exit expects Int" )
653761 ));
654762
763+ (* -- Directory operations ------------------------------------------------ *)
764+ (" list_dir" , VBuiltin (" list_dir" , fun args ->
765+ match args with
766+ | [VString path] ->
767+ (try
768+ let handle = Unix. opendir path in
769+ let entries = ref [] in
770+ (try while true do
771+ let entry = Unix. readdir handle in
772+ if entry <> " ." && entry <> " .." then
773+ entries := entry :: ! entries
774+ done with End_of_file -> () );
775+ Unix. closedir handle;
776+ Ok (VVariant (" Ok" , Some (VArray (Array. of_list
777+ (List. rev_map (fun s -> VString s) ! entries)))))
778+ with
779+ | Unix. Unix_error (_ , _ , msg ) ->
780+ Ok (VVariant (" Err" , Some (VString (" list_dir: " ^ msg))))
781+ | Sys_error msg ->
782+ Ok (VVariant (" Err" , Some (VString msg))))
783+ | _ -> Error (TypeMismatch " list_dir expects String" )
784+ ));
785+ (" create_dir" , VBuiltin (" create_dir" , fun args ->
786+ match args with
787+ | [VString path] ->
788+ (try
789+ Unix. mkdir path 0o755 ;
790+ Ok (VVariant (" Ok" , Some VUnit ))
791+ with
792+ | Unix. Unix_error (_ , _ , msg ) ->
793+ Ok (VVariant (" Err" , Some (VString (" create_dir: " ^ msg))))
794+ | Sys_error msg ->
795+ Ok (VVariant (" Err" , Some (VString msg))))
796+ | _ -> Error (TypeMismatch " create_dir expects String" )
797+ ));
798+ (" remove_dir" , VBuiltin (" remove_dir" , fun args ->
799+ match args with
800+ | [VString path] ->
801+ (try
802+ Unix. rmdir path;
803+ Ok (VVariant (" Ok" , Some VUnit ))
804+ with
805+ | Unix. Unix_error (_ , _ , msg ) ->
806+ Ok (VVariant (" Err" , Some (VString (" remove_dir: " ^ msg))))
807+ | Sys_error msg ->
808+ Ok (VVariant (" Err" , Some (VString msg))))
809+ | _ -> Error (TypeMismatch " remove_dir expects String" )
810+ ));
811+ (" setenv" , VBuiltin (" setenv" , fun args ->
812+ match args with
813+ | [VString name; VString value] ->
814+ (try
815+ Unix. putenv name value;
816+ Ok (VVariant (" Ok" , Some VUnit ))
817+ with
818+ | Unix. Unix_error (_ , _ , msg ) ->
819+ Ok (VVariant (" Err" , Some (VString (" setenv: " ^ msg)))))
820+ | _ -> Error (TypeMismatch " setenv expects (String, String)" )
821+ ));
822+ (" chdir" , VBuiltin (" chdir" , fun args ->
823+ match args with
824+ | [VString path] ->
825+ (try
826+ Unix. chdir path;
827+ Ok (VVariant (" Ok" , Some VUnit ))
828+ with
829+ | Unix. Unix_error (_ , _ , msg ) ->
830+ Ok (VVariant (" Err" , Some (VString (" chdir: " ^ msg))))
831+ | Sys_error msg ->
832+ Ok (VVariant (" Err" , Some (VString msg))))
833+ | _ -> Error (TypeMismatch " chdir expects String" )
834+ ));
835+
655836 (* -- Time --------------------------------------------------------------- *)
656837 (" time_now" , VBuiltin (" time_now" , fun _args ->
657838 Ok (VFloat (Sys. time () ))
0 commit comments