Source

ocaml-lib / monad / example_sparql.ml

Full commit

type var = string
type term = URI of string | Literal of string | Var of var
type binding = (var * term option) list

let project lv binding =
  List.map (fun v -> try List.assoc v binding with _ -> None) lv

class type state =
object
  method binding : binding
  method bind : binding -> state
  method get : var -> term option
  method subst : term -> term
  method triples : term * term * term -> binding list
end

type gp = unit u_monad with u_state = state and u_error = string
type constr = bool u_monad with u_state = state and u_error = string
type expr = term u_monad with u_state = state and u_error = string
type query = (term option list) u_monad with u_state = state and u_error = string

let get v : expr = u_def (
  let state = u_state in
  match state#get v with
    | Some t -> return t
    | None -> raise "unbound variable")

(* queries *)

let ask (p : gp) : query = u_def (succeeds p; return [])

let select (lv : var list) (p : gp) = u_def (p; let state = u_state in return (project lv state#binding))

(* graph patterns *)

let triple (s : term) (p : term) (o : term) = u_def (
  let state = u_state in
  let s = return (state#subst s) in
  let p = return (state#subst p) in
  let o = return (state#subst o) in
  let binding = LogicMonad.List.choose (state#triples (s,p,o)) in
  u_state <- state#bind binding)

let join (p1 : gp) (p2 : gp) : gp = u_def (p1; p2)

let union (p1 : gp) (p2 : gp) : gp = u_def (p1 | p2)

let minus (p1 : gp) (p2 : gp) : gp = u_def (p1; fails p2)

let optional (p1 : gp) : gp = u_def (if _ = p1 then return () else return ())

let filter (p : gp) (c : constr) : gp = u_def (p; let b = c in guard b)

let bind (v : var) (t : term) : gp = u_def (
  let state = u_state in
  match state#get v with
    | Some t0 -> guard (t0 = t)
    | None -> u_state <- state#bind [(v, Some t)])

class type aggregator =
object
  method put : term list -> term -> unit
  method get : (term list * term) u_monad
end

let aggreg (init : 'a) (f : 'a -> term option -> 'a) (h : 'a -> term option) ~(group_by : var list) ~(as_ : var) (y : var) (p1 : gp) : gp =
  let lz = group_by in
  let x = as_ in
  u_def (
    let l = fold
      (fun l binding ->
	let k = List.map binding#get lz in
	let v = binding#get y in
	let v0 = try List.assoc k l with Not_found -> init in
	(k, f v0 v) :: List.remove_assoc k l)
      []
      (u_def (p1; u_state)) in
    let k, v = LogicMonad.List.choose l in
    let state = u_state in
    u_state <- state#bind ((x, h v) :: List.combine lz k))

let count =
  aggreg 0
    (fun n -> function None -> n | Some _ -> n+1)
    (fun n -> Some (Literal (string_of_int n)))
let count_distinct =
  aggreg []
    (fun l -> function None -> l | Some x -> if List.mem x l then l else x::l)
    (fun l -> Some (Literal (string_of_int (List.length l))))
let group_concat ?(sep = "") =
  aggreg ""
    (fun s -> function Some (Literal s2) -> if s="" then s2 else s^sep^s2 | _ -> s)
    (fun s -> if s="" then None else Some (Literal s))

(* constraints *)

let exists (p1 : gp) : constr = u_def (if _ = succeeds p1 then return true else return false)

let not_exists (p1 : gp) : constr = u_def (if _ = fails p1 then return true else return false)

let diff (v1 : var) (v2 : var) : constr = u_def (let t1 = get v1 in let t2 = get v2 in return (t1 = t2))

(* expressions *)

let concat (v1 : var) (v2 : var) : expr = u_def (
  let t1 = get v1 in
  let t2 = get v2 in
  match t1, t2 with
    | Literal s1, Literal s2 -> return (Literal (s1^s2)))


(* examples *)

(* let q_femme = u_def (let x = femme in u_return x) = u_def femme = femme *)
let q_femme = select ["x"] (triple (Var "x") (URI "a") (URI "femme"))

(* let q_person = u_def (femme | homme) *)

(* let q_brother = u_def (let x,z = parent in let y,z = parent in u_guard (x <> y); u_return (x,y)) *)
let q_brother = select ["x";"y"]
  (filter
     (join
	(triple (Var "x") (URI "parent") (Var "z"))
	(triple (Var "y") (URI "parent") (Var "z")))
     (diff "x" "y"))

let q_child_count = select ["x";"n"]
  (count_distinct "y" ~as_:"n"
     (triple (Var "y") (URI "parent") (Var "x"))
     ~group_by:["x"])