james woodyatt avatar james woodyatt committed 45c580e

Finish refactor of Cf_dfa into Cf_xdfa module.

Comments (0)

Files changed (1)

     val nil: 'a x
     
     type 'a r
+    type 'a t = (S.t, 'a) Cf_llscan.t
+    
+    module Op: sig
+        val ( $| ): 'a x -> 'a x -> 'a x
+        val ( $& ): 'a x -> 'a x -> 'a x
+        
+        val ( !* ): 'a x -> 'a x
+        val ( !+ ): 'a x -> 'a x
+        val ( !? ): 'a x -> 'a x
+        val ( !: ): S.t -> 'a x
+        val ( !^ ): (S.t -> bool) -> 'a x
+        val ( !~ ): S.t Cf_seq.t -> 'a x
+        
+        val ( $= ): 'a x -> 'a -> 'a r
+        val ( $> ): 'a x -> (S.t Cf_seq.t -> 'a) -> 'a r
+        val ( $@ ): 'a x -> (int -> 'a t) -> 'a r
+        val ( !@ ): 'a r list -> 'a r
+    end
+    
+    val create: 'a r -> 'a t
 end
 
 module Create(S: Symbol) : (T with module S = S) = struct
     module S = S
     
-    class virtual ['a] satisfier state =
+    class virtual ['r] satisfy state =
         object(_:'self)
-            constraint 'f = int -> (S.t, 'a) Cf_llscan.t
-            
             val state_ = state
             
             method state = state_
             method follow u = {< state_ = N_set.union state_ u >}
             method virtual edge: S.t -> N_set.t -> N_set.t
-            method accept = (None : 'f option)
+            method accept: (int -> (S.t, 'r) Cf_llscan.t) option = None
         end
     
     let literal c =
         object
-            inherit ['r] satisfier N_set.nil
+            inherit ['r] satisfy N_set.nil
             method edge n u = if n = c then N_set.union state_ u else u
         end
         
     let mapped f =
         object
-            inherit ['r] satisfier N_set.nil
+            inherit ['r] satisfy N_set.nil
             method edge n u = if f n then N_set.union state_ u else u
         end
     
         y_first: N_set.t;
         y_last: N_set.t;
         y_follow: 's N_map.t -> 's N_map.t;
-    } constraint 's = 'a #satisfier
+    } constraint 's = 'r #satisfy
     
     type 's w = {
         w_null: bool;
         w_cons: int -> 's y;
     }
     
-    type 'a x = 'a satisfier w
+    type 'a x = 'a satisfy w
     
     let nil = {
         w_null = true;
             }
     }
     
-    type 'a r = 'a satisfier w
+    let acceptor f =
+        object(self:'self)
+            inherit ['r] satisfy N_set.nil
+            
+            method edge _ u = u
+            method follow _ = (self :> 'self)
+            method accept = Some f
+        end
+    
+    type 'a r = 'a satisfy w
+    type 'a t = (S.t, 'a) Cf_llscan.t
+    
+    module Op = struct
+        let ( $| ) wa wb = {
+            w_null = wa.w_null || wb.w_null;
+            w_cons = fun i ->
+                let ya = wa.w_cons i in
+                let yb = wb.w_cons ya.y_counter in {
+                    y_counter = yb.y_counter;
+                    y_first = N_set.union ya.y_first yb.y_first;
+                    y_last = N_set.union ya.y_last yb.y_last;
+                    y_follow = fun m -> yb.y_follow (ya.y_follow m);
+                }
+        }
+        
+        let follow_fold_aux a m i =
+            N_map.replace (i, let sat = N_map.search i m in sat#follow a) m
+        
+        let ( $& ) wa wb = {
+            w_null = wa.w_null && wb.w_null;
+            w_cons = fun i -> 
+                let ya = wa.w_cons i in
+                let yb = wb.w_cons ya.y_counter in
+                let first =
+                    if wa.w_null then
+                        N_set.union ya.y_first yb.y_first
+                    else
+                        ya.y_first
+                and last =
+                    if wb.w_null then
+                        N_set.union ya.y_last yb.y_last
+                    else
+                        yb.y_last
+                in {
+                    y_counter = yb.y_counter;
+                    y_first = first;
+                    y_last = last;
+                    y_follow = fun m ->
+                        let m = yb.y_follow (ya.y_follow m) in
+                        N_set.fold (follow_fold_aux yb.y_first) m ya.y_last
+                }
+        }
+        
+        let ( !* ) w =
+            let cons i =
+                let y = w.w_cons i in
+                let f = follow_fold_aux y.y_first in
+                let follow m = N_set.fold f (y.y_follow m) y.y_last in
+                { y with y_follow = follow }
+            in
+            {
+                w_null = true;
+                w_cons = cons;
+            }
+        
+        let ( !? ) x = x $| nil
+        let ( !+ ) x = x $& (!* x)
+        
+        let ( !: ) i = expr (literal i)
+        let ( !^ ) f = expr (mapped f)
+        
+        let rec ( !~ ) s =
+            match Lazy.force s with
+            | Cf_seq.Z -> nil
+            | Cf_seq.P (hd, tl) -> !:hd $& !~tl
+        
+        let ( $= ) x k =
+            let f n z = Some (k, Cf_seq.shift n z) in
+            x $& (expr (acceptor f))
+        
+        let ( $> ) x f =
+            let g n z =
+                let hd = Cf_seq.limit n z and tl = Cf_seq.shift n z in
+                Some (f hd, tl)
+            in
+            x $& (expr (acceptor g))
+        
+        let ( $@ ) x f =
+            x $& (expr (acceptor f))
+        
+        let ( !@ ) =
+            let rec f e = function hd :: tl -> f (hd $| e) tl | [] -> e in
+            fun s -> f nil s
+    end
+    
+    module S_order = struct
+        type t = int array
+        
+        let compare = compare
+            
+        (*
+        let to_string a =
+            let b = Buffer.create 40 in
+            Buffer.add_string b "[|";
+            begin
+                match Array.length a with
+                | 0 -> ()
+                | 1 ->
+                    Buffer.add_string b (Printf.sprintf " %u" a.(0))
+                | n ->
+                    for i = 0 to n - 2 do
+                        Buffer.add_string b (Printf.sprintf " %u;" a.(i))
+                    done;
+                    Buffer.add_string b (Printf.sprintf " %u" a.(n - 1))
+            end;
+            Buffer.add_string b " |]";
+            Buffer.contents b
+        *)
+    end
+    
+    module S_map = Cf_rbtree.Map(S_order)
+    
+    type ('i, 'o) s = {
+        s_id: S_order.t;
+        s_accept: (int -> ('i, 'o) Cf_llscan.t) option;
+        s_next: ('i, 'o) s option Lazy.t S.map;
+    }
+    
+    let create_aux =
+        let suspend w =
+            let y = w.w_cons 0 in
+            let m = y.y_follow N_map.nil in
+            let edge n u p = let sat = N_map.search p m in sat#edge n u in
+            let rec accept u ul i =
+                if i < ul then begin
+                    let sat = N_map.search (Array.unsafe_get u i) m in
+                    match sat#accept with
+                    | None -> accept u ul (succ i)
+                    | v -> v
+                end
+                else
+                    None
+            in
+            let sh = ref S_map.nil in
+            let rec state u =
+                let s = {
+                    s_id = u;
+                    s_accept = accept u (Array.length u) 0;
+                    s_next = S.map (follow u);
+                } in
+                sh := S_map.replace (u, s) !sh;
+                s
+            and follow u n =
+                lazy begin
+                    let v = Array.fold_left (edge n) N_set.nil u in
+                    if N_set.empty v then
+                        None
+                    else
+                        let u = Array.of_list (N_set.to_list_incr v) in
+                        Some (try S_map.search u !sh with Not_found -> state u)
+                end
+            in
+            state (Array.of_list (N_set.to_list_incr y.y_first))
+        in
+        let nil _ _ = None in
+        let rec loop code s f n z0 z =
+            let f = match s.s_accept with None -> f | Some f -> f in
+            match Lazy.force z with
+            | Cf_seq.Z ->
+                f n z0
+            | Cf_seq.P (hd, tl) ->
+                match Lazy.force (S.get s.s_next (code hd)) with
+                | None -> f n z0
+                | Some s -> loop code s f (succ n) z0 tl
+        in
+        fun code r ->
+            let s = suspend r in
+            fun z ->
+                loop code s nil 0 z z
+    
+    let create r = create_aux identity r
 end
 
 (*--- $File$ ---*)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.