refactor: use modules for handlers to make coding less gnarly

RedPRL · Jul 8, 2022 · b2375f9 · b2375f9
1 parent 23ef8ac
commit b2375f9
Show file tree

Hide file tree

Showing 7 changed files with 225 additions and 155 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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