Source file update.ml

(*********************************************************************************)
(*                OCaml-RDF                                                      *)
(*                                                                               *)
(*    Copyright (C) 2012-2024 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)

open Sparql_types;;
open Graph;;
open Sparql_ms;;

module Bm = Graph.Bid_map

let get_bnode g bm id =
  let id = Term.blank_id_of_string id in
  try
    let id = Bm.find id bm in
    (id, bm)
  with
    Not_found ->
      let id2 = g.new_blank_id () in
      let bm = Bm.add id id2 bm in
      (id2, bm)

let var_or_term_apply_sol ~blanks_allowed ~map_blanks g sol bnode_map = function
  Sparql_types.Var v ->
    (
     try
       let node = Sparql_ms.mu_find_var v sol in
       match node with
         Term.Blank_ label ->
           if blanks_allowed then
             if map_blanks then
               begin
                 let label = Term.string_of_blank_id label in
                 let (label, bnode_map) = get_bnode g bnode_map label in
                 (Term.blank_ label, bnode_map)
               end
             else
               (node, bnode_map)
           else
             failwith "Blank nodes not allowed"
       | Term.Blank -> assert false
       | node -> (node, bnode_map)
     with Not_found ->
       failwith ("Unbound variable "^v.var_name)
    )
| Sparql_types.GraphTerm t ->
    match t with
    | GraphTermIri (PrefixedName _) -> assert false
    | GraphTermIri (Iriref _) -> assert false
    | GraphTermIri (Iri i) -> (Term.Iri (i.iri_iri), bnode_map)
    | GraphTermLit lit
    | GraphTermNumeric lit
    | GraphTermBoolean lit -> (Term.Literal lit.rdf_lit, bnode_map)
    | GraphTermBlank { bnode_label = None }
    | GraphTermNil ->
       let label = g.new_blank_id () in
       (Term.blank_ label, bnode_map)
    | GraphTermBlank { bnode_label = Some label } ->
        if blanks_allowed then
          if map_blanks then
            let (label, bnode_map) = get_bnode g bnode_map label in
            (Term.blank_ label, bnode_map)
          else
            (Term.blank label, bnode_map)
        else
          failwith "Blank nodes not allowed"
    | GraphTermNode _ -> assert false
;;

let apply_solution_to_graph
  ?(blanks_allowed=true)
  ?(on_exc=fun e -> Log.debug (fun m -> m "%s" (Printexc.to_string e)))
  ~map_blanks apply graph template =
  let triples =
    List.fold_left
      Sparql_algebra.translate_triples_same_subject_path [] template
  in
  Log.debug (fun m ->
    m "construct %d triple(s) per solution" (List.length triples));
  let build_triple sol (triples, bnode_map) (sub, path, obj) =
    try
      let pred =
        match path with
          Sparql_algebra.Var v -> Sparql_types.Var v
        | Sparql_algebra.Iri iri ->
            Sparql_types.GraphTerm
              (Sparql_types.GraphTermIri (Sparql_types.Iri iri))
        | _ -> failwith "Invalid predicate spec in template"
      in
      let (sub, bnode_map) =
        let (node, bnode_map) =
          var_or_term_apply_sol ~blanks_allowed ~map_blanks graph sol bnode_map sub
        in
        match node with
          Term.Literal _ -> failwith "Invalid subject (literal)"
        | _ -> (node, bnode_map)
      in
      let (pred, bnode_map) =
        let (node, bnode_map) =
          var_or_term_apply_sol ~blanks_allowed ~map_blanks graph sol bnode_map pred
        in
        match node with
        | Term.Iri iri -> (iri, bnode_map)
        | Term.Literal _ -> failwith "Invalid predicate (literal)"
        | Term.Blank | Term.Blank_ _ -> failwith "Invalid predicate (blank)"
      in
      let (obj, bnode_map) =
        var_or_term_apply_sol ~blanks_allowed ~map_blanks graph sol bnode_map obj
      in
      ((sub, pred, obj) :: triples, bnode_map)
    with
      e ->
        on_exc e ;
        (triples, bnode_map)
  in
  let f sol =
    (*Sparql_ms.SMap.iter
      (fun name term -> print_string (name^"->"^(Term.string_of_node term)^" ; "))
      sol.Sparql_ms.mu_bindings;
    print_newline();
    *)
    let (triples,_) =
      List.fold_left (build_triple sol) ([], Bm.empty) triples
    in
    List.iter (apply graph) triples
  in
  f
;;

let add_solution_to_graph ?blanks_allowed ?on_exc =
  apply_solution_to_graph ?blanks_allowed ?on_exc ~map_blanks: true
    (fun g (sub,pred,obj) -> g.add_triple ~sub ~pred ~obj)

let del_solution_from_graph ?blanks_allowed ?on_exc =
  apply_solution_to_graph ?blanks_allowed ?on_exc ~map_blanks: false
    (fun g (sub,pred,obj) -> g.rem_triple ~sub ~pred ~obj)

let on_quad_data f g ?(mu=Sparql_ms.mu_0) qd =
  (match qd.quads_list with
   | _::_ -> Log.warn
       (fun m -> m "... { GRAPH ... { triples } } not implemented yet")
   | [] -> ()
  );
  match qd.quads_triples with
    None -> ()
  | Some template -> f g template mu

let insert_data ~graph qd =
  on_quad_data (add_solution_to_graph ~blanks_allowed:false ~on_exc:raise) graph qd;
  true

let delete_data ~graph qd =
  on_quad_data (del_solution_from_graph ~blanks_allowed: false ~on_exc:raise) graph qd;
  true

let modify ~graph m =
  let ds = Ds.simple_dataset graph in
  let query_modifier = {
      solmod_loc = m.umod_loc ;
      solmod_group = [] ;
      solmod_having = [] ;
      solmod_order = None ;
      solmod_limoff = None ;
    }
  in
  let q = {
      Sparql_algebra.query_proj = Some { sel_flag = None ; sel_vars = SelectAll } ;
      query_where = m.umod_where ;
      query_modifier ;
      query_values = None ;
    }
  in
  let algebra = Sparql_algebra.translate_query_level q in
  Log.debug (fun m -> m "%s" (Sparql_algebra.string_of_algebra algebra));
  Log.debug (fun m -> m "%s" (Ttl.to_string ds.Ds.default));
  let ctx = Sparql_eval.context ~base:(graph.name())
    ~from: [] ~from_named: Ds.NameSet.empty ds
  in
  let solutions = Sparql_eval.eval_list ctx algebra in
  let apply_solutions f = function
    None -> ()
  | Some qp -> List.iter (fun mu -> on_quad_data f graph ~mu qp) solutions
  in
  apply_solutions
    (del_solution_from_graph ~blanks_allowed:true) m.umod_delete ;
  apply_solutions
    (add_solution_to_graph ~blanks_allowed:true) m.umod_insert ;
  true

let delete_where ~graph qp =
  (match qp.quads_list with
   | _::_ -> Log.warn
       (fun m -> m "DELETE WHERE { GRAPH ... { triples }} not implemented yet")
   | [] -> ()
  );
  match qp.quads_triples with
    None -> true
  | Some template ->
      let triples_block = {
          triples_loc = qp.quads_loc ;
          triples = template ;
        }
      in
      let graph_pattern_elt = Triples triples_block in
      let ggp_sub = {
          ggp_sub_loc = qp.quads_loc ;
          ggp_sub_elts = [graph_pattern_elt] ;
        }
      in
      let m = {
          umod_loc = qp.quads_loc ;
          umod_iri = None ;
          umod_delete = Some qp ;
          umod_insert = None ;
          umod_using = [] ;
          umod_where = GGPSub ggp_sub ;
        }
      in
      modify ~graph m