Commits

camlspotter  committed 1e6bd36

added hasexp files

  • Participants

Comments (0)

Files changed (8)

+name = "hasexp"
+version = "0.0.1"
+description = "haxml for sexp"
+requires = "pcre sexplib type-conv xml-light"
+archive(byte) = "hasexp.cmo"
+archive(native) = "hasexp.cmx"
+OCAMLCFLAGS   += -annot -w Ae
+OCAMLOPTFLAGS   += -annot -w Ae
+
+OCAMLDEPFLAGS= -syntax camlp4o -package sexplib.syntax 
+OCAMLPPFLAGS= -syntax camlp4o -package sexplib.syntax 
+
+FILES[] =
+    zlist
+    xmlsexp
+    combinator
+
+OCAMLPACKS[] =
+    pcre
+    sexplib
+    type-conv
+    xml-light
+
+MyOCamlPackage(hasexp, $(FILES), $(EMPTY), $(EMPTY))

File combinator.ml

+open Sexplib
+open Sexp
+
+module Z = Zlist.Lazy
+let (!!) = Z.(!!)
+open Zlist.Infix
+
+type filter = Sexp.t -> Sexp.t Zlist.t
+
+let none : filter = fun _ -> Zlist.nil
+let keep : filter = fun t -> Zlist.singleton t
+
+let atom : filter = fun t -> match t with
+  | Atom _ -> Zlist.singleton t
+  | _ -> Zlist.nil
+;;
+
+let list : filter = fun t -> match t with
+  | List _ -> Zlist.singleton t
+  | _ -> Zlist.nil
+;;
+
+let children : filter = function
+  | List ts -> Zlist.of_list ts
+  | _ -> Zlist.nil
+;;
+
+let (^|) f g = fun x -> g (f x)
+
+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 (/>) 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
+
+let (|>|) f g = fun t ->
+  let t' = f t in
+  if not (Zlist.is_nil t') then t' else g t
+
+let rec deep f = 
+  (* eta-expansion requred to prevent inf loop *)
+  f |>| fun t -> (deep f ^. children) t
+
+let rec deepest f = (fun t -> (deepest f ^. children) t) |>| f
+
+module Xml = struct
+  let pcdata = atom
+  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
+
+  let tag = tag_p (fun _ -> true)
+  let tag_named s = tag_p (fun s' -> s = s')
+
+  let contents t =
+    match t with
+    | List [ List [ Atom "tag"; Atom _ ];
+	     List [ Atom "attrs"; List _ ];
+	     List [ Atom "contents"; List ts ] ] -> Zlist.of_list ts
+    | _ -> Zlist.nil
+
+  let filter_attrs p t =
+    match t with
+    | List [ List [ Atom "tag"; Atom _ ];
+	     List [ Atom "attrs"; List ts ];
+	     List [ Atom "contents"; List _ ] ] -> 
+	begin
+	  Zlist.of_list ts >>= function
+	    | (List [Atom s1; Atom s2] as attr) when p s1 s2 -> 
+		Zlist.singleton attr
+	    | _ -> Zlist.nil
+	end
+
+    | _ -> Zlist.nil
+
+  let filter_map_attrs p t =
+    match t with
+    | List [ List [ Atom "tag"; Atom _ ];
+	     List [ Atom "attrs"; List ts ];
+	     List [ Atom "contents"; List _ ] ] -> 
+	begin
+	  Zlist.of_list ts >>= function
+	    | List [Atom s1; Atom s2] ->
+		begin match p s1 s2 with
+		| Some v -> Zlist.singleton v
+		| None -> Zlist.nil
+		end
+	    | _ -> Zlist.nil
+	end
+
+    | _ -> Zlist.nil
+
+  let attrs = filter_attrs (fun _ _ -> true)
+
+  let assoc_attrs k =
+    filter_map_attrs (fun key v ->
+      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
+    | [] -> invalid_arg k
+    | [Atom x] -> conv x (* CR jfuruse: optimize *)
+    | _ -> invalid_arg k
+  ;;
+
+  module Make = struct
+    let pcdata s = Atom s
+
+    let tag s ~attrs ts =
+      List [ List [ Atom "tag"; Atom s ];
+	     List [ Atom "attrs"; List attrs ];
+	     List [ Atom "contents"; List ts ] ] 
+  end
+end
+
+module Caml = struct
+  let string v = Atom v
+  let record_elt l v = List [Atom l; v]
+end

File combinator.mli

+open Sexplib
+open Sexp
+
+type filter = Sexp.t -> Sexp.t Zlist.t
+
+val none : filter
+val keep : filter
+val atom : filter
+val list : filter
+val children : 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
+
+module Xml : sig
+  val pcdata : filter
+  val tag : filter
+  val tag_named : string -> filter
+  val tag_p : (string -> bool) -> filter 
+
+  val contents : filter
+  val attrs : filter
+  val filter_attrs : (string -> string -> bool) -> filter
+  val filter_map_attrs : (string -> string -> Sexp.t option) -> filter
+  val assoc_attrs : string -> filter
+
+  val assoc_attrs_conv : string -> (string -> 'a) -> Sexp.t -> 'a
+
+  module Make : sig
+    val pcdata : string -> Sexp.t
+    val tag : string -> attrs:Sexp.t list -> Sexp.t list -> Sexp.t
+  end
+end
+
+module Caml : sig
+  val string : string -> Sexp.t
+  val record_elt : string -> Sexp.t -> Sexp.t
+end
+open Sexplib
+open Sexp
+
+open Xml
+
+let rec to_sexp = function
+  | PCData s -> Atom s
+  | Element (tag, kvs, children) -> 
+      let kvs = List.map (fun (k,v) -> List [Atom k; Atom v]) kvs in
+      (* CR jfuruse: warn: it is not tail rec *)
+      let children = List.map to_sexp children in
+      List [ List [ Atom "tag"; Atom tag ];
+	     List [ Atom "attrs"; List kvs ];
+	     List [ Atom "contents"; List children ] ]
+;;
+
+let rec to_xml = function
+  | Atom s -> PCData s
+  | List [ List [ Atom "tag"; Atom tag ];
+	   List [ Atom "attrs"; List kvs ];
+	   List [ Atom "contents"; List children ] ] ->
+      let kvs = List.map to_attr kvs in
+      (* CR jfuruse: warn: it is not tail rec *) 
+      let children = List.map to_xml children in
+      Element (tag, kvs, children)
+  | _ -> invalid_arg "to_xml"
+
+and to_attr = function
+  | List [ Atom k; Atom v ] -> k, v
+  | _ -> invalid_arg "to_attr"
+;;
+open Sexplib
+
+val to_sexp : Xml.xml -> Sexp.t
+
+val to_xml : Sexp.t -> Xml.xml
+  (** may raise [Invalid_arg _] *)
+TYPE_CONV_PATH "Zlist"
+
+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
+open Z.Infix
+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 of_list l =
+  let rec of_list = function
+    | [] -> Z.return Nil
+    | x::xs -> Z.return (Cons (x, of_list xs))
+  in
+  ref (of_list l)
+
+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)
+
+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)
+;;
+
+module Lazy : sig
+  type 'a t
+  val (!!) : 'a Lazy.t -> 'a
+end
+
+type 'a t with sexp
+
+val nil : 'a t
+val cons : 'a -> 'a t -> 'a t
+val (^^) : 'a -> 'a t -> 'a t
+
+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
+
+val npeek : 'a t -> int -> 'a list
+val of_list : 'a list -> 'a t
+val create : (unit -> 'a option) -> 'a t
+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
+
+(* 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