From b2375f9e4b439e5989b45105b85847814739b6ea Mon Sep 17 00:00:00 2001 From: Jon Sterling Date: Fri, 8 Jul 2022 13:35:47 +0200 Subject: [PATCH] refactor: use modules for handlers to make coding less gnarly --- src/Modifier.ml | 75 +++++++++++++++----------- src/Modifier.mli | 29 ++++++---- src/Scope.ml | 47 ++++++++++------- src/Scope.mli | 18 ++++--- src/Yuujinchou.mli | 122 ++++++++++++++++++++++++------------------- test/Example.ml | 75 ++++++++++++++------------ test/TestModifier.ml | 14 +++-- 7 files changed, 225 insertions(+), 155 deletions(-) diff --git a/src/Modifier.ml b/src/Modifier.ml index c0b0d8d5..1628bff1 100644 --- a/src/Modifier.ml +++ b/src/Modifier.ml @@ -1,12 +1,6 @@ open Bwd open BwdNotation -type ('data, 'tag, 'hook, 'context) handler = { - not_found : 'context option -> Trie.bwd_path -> unit; - shadow : 'context option -> Trie.bwd_path -> 'data * 'tag -> 'data * 'tag -> 'data * 'tag; - hook : 'context option -> Trie.bwd_path -> 'hook -> ('data, 'tag) Trie.t -> ('data, 'tag) Trie.t; -} - module type Param = sig type data @@ -15,19 +9,34 @@ sig type context end +module type Handler = +sig + module P : Param + val not_found : P.context option -> Trie.bwd_path -> unit + val shadow : P.context option -> Trie.bwd_path -> P.data * P.tag -> P.data * P.tag -> P.data * P.tag + val hook : P.context option -> Trie.bwd_path -> P.hook -> (P.data, P.tag) Trie.t -> (P.data, P.tag) Trie.t +end + + module type S = sig - include Param + module P : Param + open P val modify : ?context:context -> ?prefix:Trie.bwd_path -> hook Language.t -> (data, tag) Trie.t -> (data, tag) Trie.t - val run : (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - val try_with : (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - val perform : (data, tag, hook, context) handler + module Handle (H : Handler with module P := P) : + sig + val run : (unit -> 'a) -> 'a + val try_with : (unit -> 'a) -> 'a + end + + module Perform : Handler with module P := P end -module Make (P : Param) : S with type data = P.data and type tag = P.tag and type hook = P.hook and type context = P.context = +module Make (P : Param) : S with module P = P = struct + module P = P include P module Internal = @@ -66,23 +75,29 @@ struct | L.M_hook id -> hook context prefix id t in go prefix - let run f h = - let open Effect.Deep in - try_with f () - { effc = fun (type a) (eff : a Effect.t) -> - match eff with - | NotFound {context; prefix} -> Option.some @@ fun (k : (a, _) continuation) -> - Algaeff.Fun.Deep.finally k @@ fun () -> h.not_found context prefix - | Shadow {context; path; former; latter} -> Option.some @@ fun (k : (a, _) continuation) -> - Algaeff.Fun.Deep.finally k @@ fun () -> h.shadow context path former latter - | Hook {context; prefix; hook; input}-> Option.some @@ fun (k : (a, _) continuation) -> - Algaeff.Fun.Deep.finally k @@ fun () -> h.hook context prefix hook input - | _ -> None } - - let try_with = run - - let perform = - { not_found = Internal.not_found; - shadow = Internal.shadow; - hook = Internal.hook } + module Handle (H : Handler with module P := P) = + struct + + let run f = + let open Effect.Deep in + try_with f () + { effc = fun (type a) (eff : a Effect.t) -> + match eff with + | NotFound {context; prefix} -> Option.some @@ fun (k : (a, _) continuation) -> + Algaeff.Fun.Deep.finally k @@ fun () -> H.not_found context prefix + | Shadow {context; path; former; latter} -> Option.some @@ fun (k : (a, _) continuation) -> + Algaeff.Fun.Deep.finally k @@ fun () -> H.shadow context path former latter + | Hook {context; prefix; hook; input}-> Option.some @@ fun (k : (a, _) continuation) -> + Algaeff.Fun.Deep.finally k @@ fun () -> H.hook context prefix hook input + | _ -> None } + + let try_with = run + end + + module Perform = + struct + module P = P + include Internal + end + end diff --git a/src/Modifier.mli b/src/Modifier.mli index c259a8c8..8bbf7ba0 100644 --- a/src/Modifier.mli +++ b/src/Modifier.mli @@ -1,11 +1,5 @@ (* See Yuujinchou.mli for documentation. *) -type ('data, 'tag, 'hook, 'context) handler = { - not_found : 'context option -> Trie.bwd_path -> unit; - shadow : 'context option -> Trie.bwd_path -> 'data * 'tag -> 'data * 'tag -> 'data * 'tag; - hook : 'context option -> Trie.bwd_path -> 'hook -> ('data, 'tag) Trie.t -> ('data, 'tag) Trie.t; -} - module type Param = sig type data @@ -14,15 +8,28 @@ sig type context end +module type Handler = +sig + module P : Param + val not_found : P.context option -> Trie.bwd_path -> unit + val shadow : P.context option -> Trie.bwd_path -> P.data * P.tag -> P.data * P.tag -> P.data * P.tag + val hook : P.context option -> Trie.bwd_path -> P.hook -> (P.data, P.tag) Trie.t -> (P.data, P.tag) Trie.t +end + module type S = sig - include Param + module P : Param + open P val modify : ?context:context -> ?prefix:Trie.bwd_path -> hook Language.t -> (data, tag) Trie.t -> (data, tag) Trie.t - val run : (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - val try_with : (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - val perform : (data, tag, hook, context) handler + module Handle (H : Handler with module P := P) : + sig + val run : (unit -> 'a) -> 'a + val try_with : (unit -> 'a) -> 'a + end + + module Perform : Handler with module P := P end -module Make (P : Param) : S with type data = P.data and type tag = P.tag and type hook = P.hook and type context = P.context +module Make (P : Param) : S with module P = P diff --git a/src/Scope.ml b/src/Scope.ml index b6007f50..e25e38ef 100644 --- a/src/Scope.ml +++ b/src/Scope.ml @@ -1,13 +1,13 @@ open Bwd open BwdNotation -type ('data, 'tag, 'hook, 'context) handler = ('data, 'tag, 'hook, 'context) Modifier.handler - module type Param = Modifier.Param +module type Handler = Modifier.Handler module type S = sig - include Param + module P : Param + open P exception Locked @@ -23,14 +23,20 @@ sig val section : ?context_visible:context -> ?context_export:context -> Trie.path -> (unit -> 'a) -> 'a - val run : ?export_prefix:Trie.bwd_path -> ?init_visible:(data, tag) Trie.t -> (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - val try_with : (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - val perform : (data, tag, hook, context) handler + module Handle (H : Handler with module P := P) : + sig + val run : ?export_prefix:Trie.bwd_path -> ?init_visible:(data, tag) Trie.t -> (unit -> 'a) -> 'a + val try_with : (unit -> 'a) -> 'a + end + + module Perform : Handler with module P := P end -module Make (P : Param) : S with type data = P.data and type tag = P.tag and type hook = P.hook and type context = P.context = + +module Make (P : Param) = struct - include P + module P = P + open P module Internal = struct @@ -74,25 +80,25 @@ struct M.exclusively @@ fun () -> S.modify @@ fun s -> {s with export = - Trie.union ~prefix:(export_prefix()) (Mod.perform.shadow context) s.export @@ + Trie.union ~prefix:(export_prefix()) (Mod.Perform.shadow context) s.export @@ Mod.modify ?context ~prefix:Emp m s.visible } let include_singleton ?context_visible ?context_export (path, x) = M.exclusively @@ fun () -> S.modify @@ fun s -> - { visible = Trie.union_singleton ~prefix:Emp (Mod.perform.shadow context_visible) s.visible (path, x); - export = Trie.union_singleton ~prefix:(export_prefix()) (Mod.perform.shadow context_export) s.export (path, x) } + { visible = Trie.union_singleton ~prefix:Emp (Mod.Perform.shadow context_visible) s.visible (path, x); + export = Trie.union_singleton ~prefix:(export_prefix()) (Mod.Perform.shadow context_export) s.export (path, x) } let unsafe_include_subtree ~context_visible ~context_export (path, ns) = S.modify @@ fun s -> - { visible = Trie.union_subtree ~prefix:Emp (Mod.perform.shadow context_visible) s.visible (path, ns); - export = Trie.union_subtree ~prefix:(export_prefix()) (Mod.perform.shadow context_export) s.export (path, ns) } + { visible = Trie.union_subtree ~prefix:Emp (Mod.Perform.shadow context_visible) s.visible (path, ns); + export = Trie.union_subtree ~prefix:(export_prefix()) (Mod.Perform.shadow context_export) s.export (path, ns) } let include_subtree ?context_visible ?context_export (path, ns) = M.exclusively @@ fun () -> unsafe_include_subtree ~context_visible ~context_export (path, ns) let import_subtree ?context (path, ns) = M.exclusively @@ fun () -> S.modify @@ fun s -> - { s with visible = Trie.union_subtree ~prefix:Emp (Mod.perform.shadow context) s.visible (path, ns) } + { s with visible = Trie.union_subtree ~prefix:Emp (Mod.Perform.shadow context) s.visible (path, ns) } let get_export () = M.exclusively @@ fun () -> (S.get()).export @@ -106,8 +112,13 @@ struct unsafe_include_subtree ~context_visible ~context_export (p, export); ans - let run ?(export_prefix=Emp) ?(init_visible=Trie.empty) f h = - Mod.run (fun () -> Internal.run ~export_prefix ~init_visible f) h - let try_with = Mod.try_with - let perform = Mod.perform + module Handle (H : Handler with module P := P) = + struct + module M = Mod.Handle (H) + let run ?(export_prefix=Emp) ?(init_visible=Trie.empty) f = + M.run (fun () -> Internal.run ~export_prefix ~init_visible f) + let try_with = M.try_with + end + + module Perform = Mod.Perform end diff --git a/src/Scope.mli b/src/Scope.mli index 8004e945..0d8cc6bc 100644 --- a/src/Scope.mli +++ b/src/Scope.mli @@ -1,12 +1,12 @@ (* See Yuujinchou.mli for documentation. *) -type ('data, 'tag, 'hook, 'context) handler = ('data, 'tag, 'hook, 'context) Modifier.handler - module type Param = Modifier.Param +module type Handler = Modifier.Handler module type S = sig - include Param + module P : Param + open P exception Locked @@ -22,9 +22,13 @@ sig val section : ?context_visible:context -> ?context_export:context -> Trie.path -> (unit -> 'a) -> 'a - val run : ?export_prefix:Trie.bwd_path -> ?init_visible:(data, tag) Trie.t -> (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - val try_with : (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - val perform : (data, tag, hook, context) handler + module Handle (H : Handler with module P := P) : + sig + val run : ?export_prefix:Trie.bwd_path -> ?init_visible:(data, tag) Trie.t -> (unit -> 'a) -> 'a + val try_with : (unit -> 'a) -> 'a + end + + module Perform : Handler with module P := P end -module Make (P : Param) : S with type data = P.data and type tag = P.tag and type hook = P.hook and type context = P.context +module Make (P : Param) : S with module P = P diff --git a/src/Yuujinchou.mli b/src/Yuujinchou.mli index 564fae35..d323d9b7 100644 --- a/src/Yuujinchou.mli +++ b/src/Yuujinchou.mli @@ -82,18 +82,6 @@ end module Modifier : sig - (** The type of effect handlers used in this module. *) - type ('data, 'tag, 'hook, 'context) handler = { - not_found : 'context option -> Trie.bwd_path -> unit; - (** [not_found ctx prefix] is called when the engine expects at least one binding within the subtree at [prefix] but could not find any, where [ctx] is the context passed to {!val:S.modify}. Modifiers such as {!val:Language.any}, {!val:Language.only}, {!val:Language.none}, and a few other modifiers expect at least one matching binding. For example, the modifier {!val:Language.except}[ ["x"; "y"]] expects that there was already something under the subtree at [x.y]. If there were actually no names with the prefix [x.y], then the modifier will trigger this effect with [prefix] being [Emp #< "x" #< "y"]. *) - - shadow : 'context option -> Trie.bwd_path -> 'data * 'tag -> 'data * 'tag -> 'data * 'tag; - (** [shadow ctx path x y] is called when item [y] is being assigned to [path] but [x] is already bound at [path], where [ctx] is the context passed to {!val:S.modify}. Modifiers such as {!val:Language.renaming} and {!val:Language.union} could lead to bindings having the same name, and when that happens, this function is called to resolve the conflicting bindings. To implement silent shadowing, one can simply return item [y]. One can also employ a more sophisticated strategy to implement type-directed disambiguation. *) - - hook : 'context option -> Trie.bwd_path -> 'hook -> ('data, 'tag) Trie.t -> ('data, 'tag) Trie.t; - (** [hook prefix id input] is called when processing the modifiers created by {!val:Language.hook}, where [ctx] is the context passed to {!val:S.modify}. When the engine encounters the modifier {!val:Language.hook}[ id] while handling the subtree [input] at [prefix], it will call [hook prefix id input] and replace the existing subtree [input] with the return value. *) - } - (** The parameters of an engine. *) module type Param = sig @@ -110,10 +98,31 @@ sig type context end + + (** The type of effect handlers used in this module. *) + module type Handler = + sig + module P : Param + open P + + val not_found : context option -> Trie.bwd_path -> unit + (** [not_found ctx prefix] is called when the engine expects at least one binding within the subtree at [prefix] but could not find any, where [ctx] is the context passed to {!val:S.modify}. Modifiers such as {!val:Language.any}, {!val:Language.only}, {!val:Language.none}, and a few other modifiers expect at least one matching binding. For example, the modifier {!val:Language.except}[ ["x"; "y"]] expects that there was already something under the subtree at [x.y]. If there were actually no names with the prefix [x.y], then the modifier will trigger this effect with [prefix] being [Emp #< "x" #< "y"]. *) + + + val shadow : context option -> Trie.bwd_path -> data * tag -> data * tag -> data * tag + (** [shadow ctx path x y] is called when item [y] is being assigned to [path] but [x] is already bound at [path], where [ctx] is the context passed to {!val:S.modify}. Modifiers such as {!val:Language.renaming} and {!val:Language.union} could lead to bindings having the same name, and when that happens, this function is called to resolve the conflicting bindings. To implement silent shadowing, one can simply return item [y]. One can also employ a more sophisticated strategy to implement type-directed disambiguation. *) + + + val hook : context option -> Trie.bwd_path -> hook -> (data, tag) Trie.t -> (data, tag) Trie.t + (** [hook prefix id input] is called when processing the modifiers created by {!val:Language.hook}, where [ctx] is the context passed to {!val:S.modify}. When the engine encounters the modifier {!val:Language.hook}[ id] while handling the subtree [input] at [prefix], it will call [hook prefix id input] and replace the existing subtree [input] with the return value. *) + + end + (** The signature of the engine. *) module type S = sig - include Param + module P : Param + open P (** @closed *) val modify : ?context:context -> ?prefix:Trie.bwd_path -> hook Language.t -> (data, tag) Trie.t -> (data, tag) Trie.t @@ -122,45 +131,49 @@ sig @param context The context sent to the effect handlers. If unspecified, effects come with {!constructor:None} as their context. @param prefix The prefix prepended to any path or prefix sent to the effect handlers. The default is the empty path ([Emp]). *) - val run : (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - (** [run f h] initializes the engine and runs the thunk [f], using [h] to handle modifier effects. See {!type:handler}. *) - - val try_with : (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - (** [try_with f h] runs the thunk [f], using [h] to handle the intercepted modifier effects. See {!type:handler}. - - Currently, [try_with] is an alias of {!val:run}, but [try_with] is intended to use within {!val:run} to intercept effects, - while {!val:run} is intended to be at the outermost layer to handle effects. That is, the following is the expected program structure: - {[ - run @@ fun () -> - (* code *) - try_with f { ... } - (* more code *) - ]} - *) - - val perform : (data, tag, hook, context) handler + module Handle (H : Handler with module P := P) : + sig + val run : (unit -> 'a) -> 'a + (** [run f h] initializes the engine and runs the thunk [f], using [h] to handle modifier effects. See {!type:handler}. *) + + val try_with : (unit -> 'a) -> 'a + (** [try_with f h] runs the thunk [f], using [h] to handle the intercepted modifier effects. See {!type:handler}. + + Currently, [try_with] is an alias of {!val:run}, but [try_with] is intended to use within {!val:run} to intercept effects, + while {!val:run} is intended to be at the outermost layer to handle effects. That is, the following is the expected program structure: + {[ + run @@ fun () -> + (* code *) + try_with f + (* more code *) + ]} + *) + end + + module Perform : Handler with module P := P (** A handler that reperforms the effects. It can also be used to manually trigger the effects; for example, [perform.not_found (Emp #< "a" #< "b")] will perform the [not_found] effect to be handled by the outer handler. *) end (** The functor to generate an engine. *) - module Make (P : Param) : S with type data = P.data and type tag = P.tag and type hook = P.hook and type context = P.context + module Make (P : Param) : S with module P = P end (** The {!module:Scope} module implements lexical scoping based on {!module:Modifier}. *) module Scope : sig - (** The type of effect handlers used in this module. *) - type ('data, 'tag, 'hook, 'context) handler = ('data, 'tag, 'hook, 'context) Modifier.handler - (** The parameters of scoping effects. *) module type Param = Modifier.Param + (** The type of effect handlers used in this module. *) + module type Handler = Modifier.Handler + (** The signature of scoping effects. *) module type S = sig - include Param + module P : Param + open P (** @closed *) exception Locked @@ -244,30 +257,33 @@ sig (** {1 Runners} *) - val run : ?export_prefix:Trie.bwd_path -> ?init_visible:(data, tag) Trie.t -> (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - (** [run f h] initializes a scope and executes the thunk [f], using [h] to handle modifier effects. + module Handle (H : Handler with module P := P) : + sig + val run : ?export_prefix:Trie.bwd_path -> ?init_visible:(data, tag) Trie.t -> (unit -> 'a) -> 'a + (** [run f h] initializes a scope and executes the thunk [f], using [h] to handle modifier effects. - @param export_prefix The additional global prefix prepended to the paths reported to effect handlers - originating from export namespaces. The default is the empty path ([Emp]). - This does not affect paths originating from visible namespaces. - @param init_visible The initial visible namespace. The default is the empty trie. *) + @param export_prefix The additional global prefix prepended to the paths reported to effect handlers + originating from export namespaces. The default is the empty path ([Emp]). + This does not affect paths originating from visible namespaces. + @param init_visible The initial visible namespace. The default is the empty trie. *) - val try_with : (unit -> 'a) -> (data, tag, hook, context) handler -> 'a - (** Execute the code and handles the internal modifier effects. This can be used to intercept - or reperform those effects; for example, the following function silences the [shadow] effects. - See also {!val:Modifier.S.try_with}. + val try_with : (unit -> 'a) -> 'a + (** Execute the code and handles the internal modifier effects. This can be used to intercept + or reperform those effects; for example, the following function silences the [shadow] effects. + See also {!val:Modifier.S.try_with}. - {[ - let silence_shadow f = try_with f {perform with shadow = fun _ _ _ y -> y} - ]} + {[ + let silence_shadow f = try_with f {perform with shadow = fun _ _ _ y -> y} + ]} - Note that {!val:run} starts a fresh empty scope while [try_with] remains in the current scope. - *) + Note that {!val:run} starts a fresh empty scope while [try_with] remains in the current scope. + *) + end - val perform : (data, tag, hook, context) handler - (** A handler that reperforms the internal modifier effects. See {!val:Modifier.S.perform}. *) + module Perform : Handler with module P := P + (** A handler that reperforms the internal modifier effects. See {!val:Modifier.S.Perform}. *) end - module Make (P : Param) : S with type data = P.data and type tag = P.tag and type hook = P.hook and type context = P.context + module Make (P : Param) : S with module P = P (** The functor to generate a module for scoping effects. *) end diff --git a/test/Example.ml b/test/Example.ml index d709a8d2..d05ef9e8 100644 --- a/test/Example.ml +++ b/test/Example.ml @@ -27,52 +27,62 @@ module S = Scope.Make (struct end) (* Handle scoping effects *) -let handler : _ Scope.handler = +module Handler = +struct let pp_path fmt = function | Emp -> Format.pp_print_string fmt "(root)" | path -> Format.pp_print_string fmt @@ String.concat "." (Bwd.to_list path) - in + let pp_context fmt = function | Some `Visible -> Format.pp_print_string fmt " in the visible namespace" | Some `Export -> Format.pp_print_string fmt " in the export namespace" | None -> () - in + let pp_item fmt = function | (x, `Imported) -> Format.fprintf fmt "%i (imported)" x | (x, `Local) -> Format.fprintf fmt "%i (local)" x - in - { not_found = - (fun context prefix -> - Format.printf - "[Warning] Could not find any data within the subtree at %a%a.@." - pp_path prefix pp_context context); - shadow = - (fun context path x y -> - Format.printf - "[Warning] Data %a assigned at %a was shadowed by data %a%a.@." - pp_item x - pp_path path - pp_item y - pp_context context; - y); - hook = - (fun context prefix hook input -> - match hook with - | Print -> - Format.printf "@[[Info] Got the following bindings at %a%a:@;" - pp_path prefix pp_context context; - Trie.iter - (fun path x -> - Format.printf "%a => %a@;" pp_path path pp_item x) - input; - Format.printf "@]@."; - input)} + + let not_found context prefix = + Format.printf + "[Warning] Could not find any data within the subtree at %a%a.@." + pp_path prefix pp_context context + + let shadow context path x y = + Format.printf + "[Warning] Data %a assigned at %a was shadowed by data %a%a.@." + pp_item x + pp_path path + pp_item y + pp_context context; + y + + let hook context prefix hook input = + match hook with + | Print -> + Format.printf "@[[Info] Got the following bindings at %a%a:@;" + pp_path prefix pp_context context; + Trie.iter + (fun path x -> + Format.printf "%a => %a@;" pp_path path pp_item x) + input; + Format.printf "@]@."; + input +end + +module SilentHandler = +struct + include Handler + let shadow _ _ _ y = y +end + (* Mute the [shadow] effects. *) -let silence_shadow f = S.try_with f {S.perform with shadow = fun _ _ _ y -> y} +let silence_shadow f = + let module SH = S.Handle (SilentHandler) in + SH.try_with f (* The interpreter *) let rec interpret_decl : decl -> unit = @@ -93,7 +103,8 @@ let rec interpret_decl : decl -> unit = S.section p @@ fun () -> List.iter interpret_decl sec let interpret (prog : program) = - S.run (fun () -> List.iter interpret_decl prog) handler + let module SH = S.Handle (Handler) in + SH.run (fun () -> List.iter interpret_decl prog) (* Some code in action *) let () = interpret [ diff --git a/test/TestModifier.ml b/test/TestModifier.ml index 10c2d101..e8eeb60d 100644 --- a/test/TestModifier.ml +++ b/test/TestModifier.ml @@ -33,11 +33,17 @@ type empty = | module M = Modifier.Make (struct type nonrec data = data type tag = unit type hook = empty type context = empty end) exception WrappedBindingNotFound of Trie.bwd_path + +module WrapHandler = +struct + let not_found _ prefix = raise @@ WrappedBindingNotFound prefix + let shadow _ path (x, ()) (y, ()) = U (path, x, y), () + let hook _ _ = function (_ : empty) -> . +end + let wrap f = - M.run f - { not_found = (fun _ prefix -> raise @@ WrappedBindingNotFound prefix); - shadow = (fun _ path (x, ()) (y, ()) -> U (path, x, y), ()); - hook = (fun _ _ -> function _ -> .) } + let module R = M.Handle (WrapHandler) in + R.run f let wrap_error f = fun () -> wrap @@ fun () -> ignore (f ())