hasexp / combinator.ml

open Sexplib
open Sexp

module Z = Zlist.Lazy
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)
(** pipe *)

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
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.