Commits

camlspotter committed 90c679b

added generalized comb and xmlcomb

Comments (0)

Files changed (8)

 OCAMLDEPFLAGS= -syntax camlp4o -package sexplib.syntax 
 OCAMLPPFLAGS= -syntax camlp4o -package sexplib.syntax 
 
-FILES[] =
-    zlist
-    xmlsexp
-    combinator
-
 OCAMLPACKS[] =
     pcre
     sexplib
     type_conv
     xml-light
+    spotlib
+
+FILES[] =
+    xmlsexp
+    combinator
+    comb
+    xmlcomb
 
 MyOCamlPackage(hasexp, $(FILES), $(EMPTY), $(EMPTY))
+open Spotlib.Spot
+
+type 'a _filter = 'a -> 'a Stream.t
+(** Type of filter, which takes a tree,
+    and returns the stream of subtrees which match with the filter criteria
+*)
+
+module type TreeType = sig
+
+  type t (** type of the tree *)
+
+  val leaf : t _filter
+  (** Return the singleton of the tree if it is a terminal node.
+      Otherwise returns null. *)
+
+  val branch : t _filter
+  (** Return the singleton of tree if it is a branch node. 
+      Otherwise returns null. *)
+
+  val children : t _filter
+  (** return the sub-nodes *)
+end 
+
+module type S = sig
+  include TreeType
+  type filter = t _filter 
+  val none : filter
+  val keep : filter
+  val ( *<| ) : filter -> filter -> filter
+  val ( *>| ) : filter -> filter -> filter
+  val ( ||| ) : filter -> filter -> filter
+  val with_   : filter -> filter -> filter
+  val without : filter -> filter -> filter
+  val ( /> )  : filter -> filter -> filter
+  val ( </ )  : filter -> filter -> filter
+  val if_ : filter -> then_:filter -> else_:filter -> filter
+  val ( |>| ) : filter -> filter -> filter
+  val deep : filter -> filter
+  val deepest : filter -> filter
+end
+
+module Make(Tree : TreeType) : S with type t := Tree.t = struct
+  open Tree
+  open Stream
+
+  include Tree
+
+  type filter = t _filter
+
+  let none _ = null
+
+  let keep t = singleton t
+
+  let ( *<| ) f g = fun t -> g t >>= f
+  let ( *>| ) f g = fun t -> f t >>= g
+
+  let (|||) f g = fun t -> append (f t) (g t)
+  let with_ f g = f *> filter (fun v -> not (is_null (g v)))
+  let without f g = f *> filter (g *> is_null)
+
+  let (/>) f g = f *>| children *>| g
+  let (</) f g = with_ f (children *>| g)
+
+  let if_ f ~then_ ~else_ = fun t -> lazy begin
+    if not (is_null (f t)) 
+    then Lazy.force (then_ t) 
+    else Lazy.force (else_ t)
+  end
+
+  let (|>|) f g = fun t -> lazy begin
+    let t' = f t in
+    if not (is_null t') then Lazy.force t' else Lazy.force (g t)
+  end
+
+  let rec deep f = 
+    (* eta-expansion requred to prevent inf loop *)
+    f |>| fun t -> (children *>| deep f) t
+
+  let rec deepest f = (fun t -> (children *>| deepest f) t) |>| f
+
+end
+
+open Spotlib.Spot
 open Sexplib
 open Sexp
 
-module Z = Zlist.Lazy
-open Zlist.Infix
+open Stream.Open
 
-type filter = Sexp.t -> Sexp.t Zlist.t
+type filter = Sexp.t -> Sexp.t Stream.t
 
-let none : filter = fun _ -> Zlist.nil
-let keep : filter = fun t -> Zlist.singleton t
+let none : filter = fun _ -> Stream.null
+let keep : filter = fun t -> Stream.singleton t
 
 let atom : filter = fun t -> match t with
-  | Atom _ -> Zlist.singleton t
-  | _ -> Zlist.nil
+  | Atom _ -> Stream.singleton t
+  | _ -> Stream.null
 ;;
 
 let list : filter = fun t -> match t with
-  | List _ -> Zlist.singleton t
-  | _ -> Zlist.nil
+  | List _ -> Stream.singleton t
+  | _ -> Stream.null
 ;;
 
 let children : filter = function
-  | List ts -> Zlist.of_list ts
-  | _ -> Zlist.nil
+  | List ts -> Stream.of_list ts
+  | _ -> Stream.null
 ;;
 
-let (^|) f g = fun x -> g (f x)
-(** pipe *)
+let (^.) f g = fun t -> Stream.bind (g t) f
+let (|||) f g = fun t -> Stream.append (f t) (g t)
 
-let (^.) f g = fun t -> Zlist.bind (g t) f
-let (|||) f g = fun t -> Zlist.append (f t) (g t)
-
-let with_ f g = f ^| Zlist.filter ~f:(fun v -> not (Zlist.is_nil (g v)))
-let without f g = f ^| Zlist.filter ~f:(g ^| Zlist.is_nil)
+let with_ f g = f *> Stream.filter (fun v -> not (Stream.is_null (g v)))
+let without f g = f *> Stream.filter (g *> Stream.is_null)
 
 let (/>) f g = g ^. children ^. f
 let (</) f g = with_ f (g ^. children)
 
 let if_ f ~then_ ~else_ = fun t ->
-  if not (Zlist.is_nil (f t)) then then_ t else else_ t
+  if not (Stream.is_null (f t)) then then_ t else else_ t
 
 let (|>|) f g = fun t ->
   let t' = f t in
-  if not (Zlist.is_nil t') then t' else g t
+  if not (Stream.is_null t') then t' else g t
 
 let rec deep f = 
   (* eta-expansion requred to prevent inf loop *)
   let tag_p p t = match t with
     | List [ List [ Atom "tag"; Atom s ];
 	     List [ Atom "attrs"; List _ ];
-	     List [ Atom "contents"; List _ ] ] when p s -> Zlist.singleton t
-    | _ -> Zlist.nil
+	     List [ Atom "contents"; List _ ] ] when p s -> Stream.singleton t
+    | _ -> Stream.null
 
   let tag = tag_p (fun _ -> true)
   let tag_named s = tag_p (fun s' -> s = s')
     match t with
     | List [ List [ Atom "tag"; Atom _ ];
 	     List [ Atom "attrs"; List _ ];
-	     List [ Atom "contents"; List ts ] ] -> Zlist.of_list ts
-    | _ -> Zlist.nil
+	     List [ Atom "contents"; List ts ] ] -> Stream.of_list ts
+    | _ -> Stream.null
 
   let filter_attrs p t =
     match t with
 	     List [ Atom "attrs"; List ts ];
 	     List [ Atom "contents"; List _ ] ] -> 
 	begin
-	  Zlist.of_list ts >>= function
+	  Stream.of_list ts >>= function
 	    | (List [Atom s1; Atom s2] as attr) when p s1 s2 -> 
-		Zlist.singleton attr
-	    | _ -> Zlist.nil
+		Stream.singleton attr
+	    | _ -> Stream.null
 	end
 
-    | _ -> Zlist.nil
+    | _ -> Stream.null
 
   let filter_map_attrs p t =
     match t with
 	     List [ Atom "attrs"; List ts ];
 	     List [ Atom "contents"; List _ ] ] -> 
 	begin
-	  Zlist.of_list ts >>= function
+	  Stream.of_list ts >>= function
 	    | List [Atom s1; Atom s2] ->
 		begin match p s1 s2 with
-		| Some v -> Zlist.singleton v
-		| None -> Zlist.nil
+		| Some v -> Stream.singleton v
+		| None -> Stream.null
 		end
-	    | _ -> Zlist.nil
+	    | _ -> Stream.null
 	end
 
-    | _ -> Zlist.nil
+    | _ -> Stream.null
 
   let attrs = filter_attrs (fun _ _ -> true)
 
       if k = key then Some (Atom v) else None)
 
   let assoc_attrs_conv k conv t =
-    match Zlist.npeek (assoc_attrs k t) 2 with
+    match Stream.to_list & Stream.take 2 (assoc_attrs k t) with
     | [] -> invalid_arg k
     | [Atom x] -> conv x (* CR jfuruse: optimize *)
     | _ -> invalid_arg k
+open Spotlib.Spot
 open Sexplib
 
-type filter = Sexp.t -> Sexp.t Zlist.t
+type filter = Sexp.t -> Sexp.t Stream.t
 (** Type of filter, which takes an Sexp tree, 
     and returns the stream of subtrees which match with the filter criteria 
 *)
 
 val none : filter
 (** returns none *)
-(** [none t] returns [nil] *)
+(** [none t] returns [null] *)
 
 val keep : filter
 (** returns the entire tree *)
 (** Combinators *)
 
 val (^.) : filter -> filter -> filter
-(** Composition. 
+(** Composition. `o` of HaXml.
     [a ^. b] filters an sexp by [b], then the result is filtered by [a].
     The result is concatenated.
 *)
+(* CR jfuruse: ( *<| ) *)
 
 val (|||) : filter -> filter -> filter
-(** [a ||| b] runs [a] and [b] on the same Sexp and returns the appended results *) 
+(** [a ||| b] runs [a] and [b] on the same Sexp and returns the appended results.
+    (|||) of HaXml.
+ *) 
 
 val with_ : filter -> filter -> filter
 (** [with_ f g] returns the result of [f] on an Sexp, filtered by [g].
     If some of the result are filtered out by [g], i.e. [g res] is null, 
     they are removed from the result of [with_ f g] on the Sexp.
+    `with` of HaXml.
  *) 
 
 val without : filter -> filter -> filter
 
 val ( /> ) : filter -> filter -> filter
 (** [f /> g] is equal to [g ^. children ^. f]. 
-    Run [f] then run [g] against the children of the result *)
+    Run [f] then run [g] against the children of the result 
+    (/>) of HaXml.
+*)
  
 val ( </ ) : filter -> filter -> filter
 (** [f </ g] is equal to [with_ f (g ^. children)]. 
-    Run [f] and returns result whose children are not filtered out by [g] *)
+    Run [f] and returns result whose children are not filtered out by [g] 
+    (</) of HaXml.
+*)
 
 val if_ : filter -> then_:filter -> else_:filter -> filter
 (** Conditional [if_ cond ~then_ ~else]: if [cond] returns non-null, 
 
 val ( |>| ) : filter -> filter -> filter
 (** Conditional like [a ? b : c] in C. [f |>| g] runs [f] and if the result is non-null returns them.
-    Otherwise it runs [g] and returns [g]'s result. *)
+    Otherwise it runs [g] and returns [g]'s result. 
+    (|>|) of HaXml.
+*)
 
 val deep : filter -> filter
-(** Depth search. At [deep f], if some Sexp matches with [f], its children are not searched. *)
+(** Depth search. At [deep f], if some Sexp matches with [f], its children are not searched. 
+    deep of HaXml.
+*)
 
 val deepest : filter -> filter
-(** Depth search. If some Sexp matches with [f], its parents are not searched. *)
+(** Depth search. If some Sexp matches with [f], its parents are not searched. 
+    deepest of HaXml.
+*)
 
 (** XML specific combinators *)
 module Xml : sig
+open Xml
+(* open Spotlib.Spot *)
+open Spotlib.Spot.Stream
+
+module Primitive = struct
+  type t = Xml.xml
+
+  let leaf = function
+    | (PCData _ as e) -> singleton e
+    | _ -> null
+
+  let pcdata = leaf
+
+  let branch = function
+    | (Element _ as e) -> singleton e
+    | _ -> null
+
+  let tag = branch
+
+  let children = function
+    | PCData _ -> null
+    | Element (_, _, xs) -> of_list xs
+
+  let tag_p p t = match t with
+    | Element (tag, _, _) when p tag -> singleton t
+    | _ -> null
+
+  let tag_named name = tag_p (fun x -> x = name)
+end
+
+include Primitive
+include Comb.Make(Primitive)
+type t = Xml.xml
+
+include Comb.S with type t := Xml.xml
+
+val pcdata : filter
+(** same as leaf *)
+
+val tag : filter
+(** same as branch *)
+
+val tag_p : (string -> bool) -> filter
+
+val tag_named : string -> filter
+

zlist.ml

-open Sexplib.Conv
-
-module Monad = struct
-  module Infix(M : sig 
-    type 'a t
-    val return : 'a -> 'a t
-    val bind : 'a t -> ('a -> 'b t) -> 'b t
-  end) = struct
-    let (>>=) = M.bind
-    let (>>|) t f = M.bind t (fun v -> M.return (f v))
-  end
-end
-
-module Lazy = struct
-  module Lazy = struct
-    include Lazy
-
-    let return : 'a -> 'a t = lazy_from_val
-    let bind z f = lazy ( force( f (force z)) )
-    let (!!) = force
-  end
-
-  include Lazy
-  module Infix = Monad.Infix(Lazy)
-end
-
-module Z = Lazy
-let (!!) = Z.(!!)
-
-type 'a zlist =
-    | Cons of 'a * 'a t
-    | Nil
-
-and 'a t = 'a zlist Z.t
-
-let nil : 'a t = Z.return Nil
-let cons v vs = Z.return (Cons (v, vs))
-let (^^) = cons
-
-let hd_tl t = 
-  match !!t with
-  | Nil -> None
-  | Cons (v, vs) -> Some (v,vs)
-
-let hd t =
-  match hd_tl t with
-  | None -> None
-  | Some (v, _) -> Some v
-
-let tl t =
-  match hd_tl t with
-  | None -> None
-  | Some (_, tl) -> Some tl
-
-let npeek t n = 
-  let rec npeek acc n t =
-    if n = 0 then acc
-    else
-      match Lazy.force t with
-      | Nil -> acc
-      | Cons (v, vs) -> npeek (v::acc) (n-1) vs
-  in
-  List.rev (npeek [] n t)
-
-let rec force t = 
-  match Lazy.force t with
-  | Nil -> ()
-  | Cons (_, vs) -> force vs
-
-let rec iter ~f t =
-  match Lazy.force t with
-  | Nil -> ()
-  | Cons (v, vs) -> f v; iter ~f vs
-
-let to_list t =
-  let rec force st t = 
-    match Lazy.force t with
-    | Nil -> List.rev st
-    | Cons (v,vs) -> force (v::st) vs
-  in
-  force [] t
-
-let create (f : unit -> 'a option) : 'a t =
-  let rec zlist () =
-    lazy (
-      match f () with
-      | None ->  Nil
-      | Some v -> Cons (v, zlist ())
-    )
-  in
-  zlist ()
-
-let is_nil t = hd t = None
-
-let rec map ~f t =
-  lazy (
-    match Lazy.force t with
-    | Nil -> Nil
-    | Cons (v, vs) -> Cons (f v, map ~f vs)
-  )
-
-let filter_map ~f t =
-  let rec filter ~f t =
-    lazy (
-      match Lazy.force t with
-      | Nil -> Nil
-      | Cons (v, vs) -> 
-	  match f v with
-	  | Some v -> Cons (v, filter ~f vs)
-	  | None -> Lazy.force (filter ~f vs)
-    )
-  in
-  filter ~f t
-
-let filter ~f t =
-  filter_map t ~f:(fun v ->
-    if f v then Some v else None)
-
-(* CR jfuruse: Completely wrong *)
-let fold_right ~f t ~init = 
-  let rec fold_right_ ~f t ~init =
-    match Lazy.force t with
-    | Nil -> init
-    | Cons (v, vs) -> f v (fold_right_ ~f vs ~init)
-  in
-  lazy (fold_right_ ~f t ~init)
-
-let rec of_list = function
-  | [] -> Z.return Nil
-  | x::xs -> Z.return (Cons (x, of_list xs))
-
-let singleton v = of_list [v]
-
-let is_singleton t = npeek t 2
-  
-let append t1 t2 =
-  let rec zlist t =
-    lazy (
-      match Lazy.force t with
-      | Cons (v,vs) -> Cons(v, zlist vs)
-      | Nil -> Lazy.force t2
-    )
-  in
-  zlist t1
-
-let return = singleton
-
-let zz z = lazy (Lazy.force (Lazy.force z))
-
-let bind = fun t f ->
-  zz (fold_right ~f:append (map ~f t) ~init:nil)
-
-module Infix = struct
-  let (^^) = (^^)
-  let (>>=) = bind
-  let (>>|) t f = bind t (fun v -> return (f v))
-end
-
-let test () =
-  assert (to_list (append (of_list [1;2;3]) (of_list [4;5;6])) 
-	   = [1;2;3;4;5;6]);
-  assert (to_list 
-	     (bind (of_list [1;2;3]) (fun n -> of_list [n*3; n*3+1; n*3+2]))
-	   = [3;4;5;6;7;8;9;10;11])
-    
-type 'a forced = 'a list with sexp
-
-let sexp_of_t sexp_of_a t =
-  sexp_of_forced sexp_of_a (to_list t)
-;;
-
-let t_of_sexp a_of_sexp l =
-  of_list (forced_of_sexp a_of_sexp l)
-;;
-

zlist.mli

-module Lazy : sig
-  type 'a t
-  val (!!) : 'a Lazy.t -> 'a
-  module Infix : sig
-    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
-    val (>>|) : 'a t -> ('a -> 'b) -> 'b t
-  end
-end
-
-type 'a t with sexp
-
-val nil : 'a t
-val cons : 'a -> 'a t -> 'a t
-val (^^) : 'a -> 'a t -> 'a t
-(** Same as [cons] *)
-
-val is_nil : 'a t -> bool
-
-val hd : 'a t -> 'a option
-val tl : 'a t -> 'a t option
-val hd_tl : 'a t -> ('a * 'a t) option
-(** Deconstruction *)
-
-val npeek : 'a t -> int -> 'a list
-val of_list : 'a list -> 'a t
-
-val create : (unit -> 'a option) -> 'a t
-(** Iterative creation of lazy list *)
-
-val singleton : 'a -> 'a t
-val is_singleton : 'a t -> 'a list
-val map : f:('a -> 'b) -> 'a t -> 'b t
-val filter : f:('a -> bool) -> 'a t -> 'a t
-val filter_map : f:('a -> 'b option) -> 'a t -> 'b t
-val fold_right : 
-  f:('a -> 'b -> 'b) -> 'a t -> init:'b -> 'b lazy_t
-val append : 'a t -> 'a t -> 'a t
-val bind : 'a t -> ('a -> 'b t) -> 'b t
-
-val of_list : 'a list -> 'a t
-
-(* force functions which may loop infinite *)
-val to_list : 'a t -> 'a list
-val force : 'a t -> unit
-val iter : f:('a -> unit) -> 'a t -> unit
-
-module Infix : sig
-  val (^^) : 'a -> 'a t -> 'a t
-  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
-  val (>>|) : 'a t -> ('a -> 'b) -> 'b t
-end
-val test : unit -> unit