Source file zed_input.ml

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
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
(*
 * zed_input.ml
 * ------------
 * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
 * Licence   : BSD3
 *
 * This file is a part of Zed, an editor engine.
 *)

module type S = sig
  type event
  type +'a t
  val empty : 'a t
  val add : event list -> 'a -> 'a t -> 'a t
  val remove : event list -> 'a t -> 'a t
  val fold : (event list -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
  val bindings : 'a t -> (event list * 'a) list
  type 'a resolver
  type 'a pack
  val pack : ('a -> 'b) -> 'a t -> 'b pack
  val resolver : 'a pack list -> 'a resolver
  type 'a result =
    | Accepted of 'a
    | Continue of 'a resolver
    | Rejected
  val resolve : event -> 'a resolver -> 'a result
end

module Make (Event : Map.OrderedType) =
struct
  type event = Event.t

  module Event_map = Map.Make (Event)

  type 'a t = 'a node Event_map.t

  and 'a node =
    | Set of 'a t
    | Val of 'a

  let empty = Event_map.empty

  let rec add events value set =
    match events with
      | [] ->
          invalid_arg "Zed_input.Make.add"
      | [event] ->
          Event_map.add event (Val value) set
      | event :: events ->
          match try Some (Event_map.find event set) with Not_found -> None with
            | None
            | Some (Val _) ->
                Event_map.add event (Set (add events value empty)) set
            | Some (Set s) ->
                Event_map.add event (Set (add events value s)) set

  let rec remove events set =
    match events with
      | [] ->
          invalid_arg "Zed_input.Make.remove"
      | [event] ->
          Event_map.remove event set
      | event :: events ->
          match try Some (Event_map.find event set) with Not_found -> None with
            | None
            | Some (Val _) ->
                set
            | Some (Set s) ->
                let s = remove events s in
                if Event_map.is_empty s then
                  Event_map.remove event set
                else
                  Event_map.add event (Set s) set

  let fold f set acc =
    let rec loop prefix set acc =
      Event_map.fold
        (fun event node acc ->
           match node with
             | Val v ->
                 f (List.rev (event :: prefix)) v acc
             | Set s ->
                 loop (event :: prefix) s acc)
        set
        acc
    in
    loop [] set acc

  let bindings set =
    List.rev (fold (fun events action l -> (events, action) :: l) set [])

  module type Pack =
  sig
    type a
    type b
    val set : a t
    val map : a -> b
  end

  type 'a pack = (module Pack with type b = 'a)
  type 'a resolver = 'a pack list

  let pack (type u) (type v) map set =
    let module Pack = struct type a = u type b = v let set = set let map = map end in
    (module Pack : Pack with type b = v)

  let resolver l = l

  type 'a result =
    | Accepted of 'a
    | Continue of 'a resolver
    | Rejected

  let rec resolve_rec : 'a. event -> 'a pack list -> 'a pack list -> 'a result = fun (type u) event acc packs ->
    match packs with
      | [] ->
          if acc = [] then
            Rejected
          else
            Continue (List.rev acc)
      | p :: packs ->
          let module Pack = (val p : Pack with type b = u) in
          match try Some (Event_map.find event Pack.set) with Not_found -> None with
            | Some (Set set) ->
                resolve_rec event (pack Pack.map set :: acc) packs
            | Some (Val v) ->
                Accepted (Pack.map v)
            | None ->
                resolve_rec event acc packs

  let resolve event sets =
    resolve_rec event [] sets
end