1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
open Bwd
open Bwd.Infix
module type Param = ModifierSigs.Param
module type Perform = ModifierSigs.Perform
module type S = ModifierSigs.S with module Language := Language
module Make (Param : Param) : S with module Param := Param =
struct
module Language = Language
open Param
type not_found_handler = context option -> Trie.bwd_path -> unit
type shadow_handler = context option -> Trie.bwd_path -> data * tag -> data * tag -> data * tag
type hook_handler = context option -> Trie.bwd_path -> hook -> (data, tag) Trie.t -> (data, tag) Trie.t
type _ Effect.t +=
| NotFound : {context : context option; prefix : Trie.bwd_path} -> unit Effect.t
| Shadow : {context : context option; path : Trie.bwd_path; former : data * tag; latter : data * tag} -> (data * tag) Effect.t
| Hook : {context : context option; prefix : Trie.bwd_path; hook : hook; input : (data, tag) Trie.t} -> (data, tag) Trie.t Effect.t
module type Perform = Perform with module Param := Param
module Perform : Perform =
struct
let not_found context prefix = Effect.perform @@ NotFound {context; prefix}
let shadow context path former latter = Effect.perform @@ Shadow {context; path; former; latter}
let hook context prefix hook input = Effect.perform @@ Hook {context; prefix; hook; input}
end
module Silence : Perform =
struct
let not_found _ _ = ()
let shadow _ _ _ d = d
let hook _ _ _ t = t
end
open Perform
let modify ?context ?(prefix=Emp) =
let module L = Language in
let rec go prefix m t =
match m with
| L.M_assert_nonempty ->
if Trie.is_empty t then not_found context prefix; t
| L.M_in (p, m) ->
Trie.update_subtree p (go (prefix <@ p) m) t
| L.M_renaming (p1, p2) ->
let t, remaining = Trie.detach_subtree p1 t in
Trie.update_subtree p2 (fun _ -> t) remaining
| L.M_seq ms ->
let f t m = go prefix m t in
List.fold_left f t ms
| L.M_union ms ->
let f ts m =
let ti = go prefix m t in
Trie.union ~prefix (shadow context) ts ti
in
List.fold_left f Trie.empty ms
| L.M_hook id -> hook context prefix id t
in go prefix
let handler ~(not_found:not_found_handler) ~(shadow:shadow_handler) ~(hook:hook_handler) : _ Effect.Deep.effect_handler =
{effc =
fun (type a) (eff : a Effect.t) ->
match eff with
| NotFound {context; prefix} -> Option.some @@ fun (k : (a, _) Effect.Deep.continuation) ->
Algaeff.Fun.Deep.finally k @@ fun () -> not_found context prefix
| Shadow {context; path; former; latter} -> Option.some @@ fun (k : (a, _) Effect.Deep.continuation) ->
Algaeff.Fun.Deep.finally k @@ fun () -> shadow context path former latter
| Hook {context; prefix; hook=hookName; input} -> Option.some @@ fun (k : (a, _) Effect.Deep.continuation) ->
Algaeff.Fun.Deep.finally k @@ fun () -> hook context prefix hookName input
| _ -> None
}
let run ?(not_found=Silence.not_found) ?(shadow=Silence.shadow) ?(hook=Silence.hook) f =
Effect.Deep.try_with f () @@ handler ~not_found ~shadow ~hook
let try_with ?(not_found=Perform.not_found) ?(shadow=Perform.shadow) ?(hook=Perform.hook) f = run ~not_found ~shadow ~hook f
let register_printer f =
Printexc.register_printer @@ function
| Effect.Unhandled (NotFound {context; prefix}) -> f (`NotFound (context, prefix))
| Effect.Unhandled (Shadow {context; path; former; latter}) -> f (`Shadow (context, path, former, latter))
| Effect.Unhandled (Hook {context; prefix; hook; input}) -> f (`Hook (context, prefix, hook, input))
| _ -> None
let () = register_printer @@ fun _ -> Some "Unhandled yuujinchou effect; use Yuujinchou.Modifier.run"
end