Source file flatten.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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Flattening. *)

module L = Log
open Rdf
module Log = L
open T
open J

type json_map = (J.key * J.json) list
type node_object = J.json list SMap.t ref
type graph = {
    mutable nodes: node_object SMap.t ;
    rdf_g: Rdf.Graph.graph ;
    mutable map : Rdf.Term.blank_id SMap.t ;
  }

let pp_node ppf node =
  SMap.iter (fun k l ->
    Format.fprintf ppf "%s => [" k;
     List.iter (fun j -> Format.fprintf ppf "%a;@." J.ppm j) l;
     Format.fprintf ppf "]\n")
    !node

let pp_graph ppf g =
  SMap.iter (fun s n -> Format.fprintf ppf "  %s=>%a@." s pp_node n) g.nodes

let make_graph name =
  let base = match name with
    | `I iri -> iri
    | `B _ -> iri_of_string ""
  in
  { nodes = SMap.empty ;
    rdf_g = Rdf.Graph.open_graph base ;
    map = SMap.empty ;
  }

let graph_get_node g entry =
  match SMap.find_opt entry g.nodes with
  | Some n -> n
  | None ->
      let n = ref (SMap.singleton "@id" [J.string entry]) in
      g.nodes <- SMap.add entry n g.nodes ;
      n

(* https://www.w3.org/TR/json-ld11-api/#generate-blank-node-identifier *)
let gen_blank_node g json =
  let bid =
    match json.data with
    | `Null -> g.rdf_g.Graph.new_blank_id ()
    | `String str when is_blank_node_id json ->
        (
         let str = remove_blank_id_prefix str in
         match SMap.find_opt str g.map with
         | None ->
             let bid = g.rdf_g.Graph.new_blank_id () in
             Log.debug (fun m -> m "new blank id map: %s -> %s"
                str (Rdf.Term.string_of_blank_id bid));
             g.map <- SMap.add str bid g.map;
             bid
         | Some bid -> bid
        )
    | _ -> error (Invalid_blank_node_id json)
  in
  "_:" ^ Rdf.Term.string_of_blank_id bid

let json_gen_blank_node g json =
  let id = gen_blank_node g json in
  J.string ?loc:json.loc id

type node_map =
  { default : graph ;
    mutable graphs : graph Ds.NameMap.t ;
  }

let pp_node_map ppf nm =
  Format.fprintf ppf "node_map:@.default=%a\n" pp_graph nm.default;
  Ds.NameMap.iter (fun name g -> Format.fprintf ppf "
    graph %a=%a\n" Ds.pp_name name pp_graph g) nm.graphs

let init_node_map default_g =
  let default = { nodes = SMap.empty; rdf_g = default_g ; map = SMap.empty } in
  { default ; graphs = Ds.NameMap.empty }

let get_graph nm = function
| "@default" -> Some nm.default
| str ->
    let name =
      if str_is_blank_node_id str then
        Some (`B (Rdf.Term.blank_id_of_string (String.sub str 2 (String.length str - 2))))
      else
        match iri_of_string str with
        | iri -> Some (`I iri)
        | exception _ ->
            Log.warn (fun m -> m "Invalid graph name %s" str);
            None
    in
    match name with
    | None -> None
    | Some name ->
        match Ds.NameMap.find_opt name nm.graphs with
        | Some g -> Some g
        | None ->
            let g  = make_graph name in
            nm.graphs <- Ds.NameMap.add name g nm.graphs ;
            Some g

(* https://www.w3.org/TR/json-ld11-api/#node-map-generation. *)
let rec node_map_generation node_map
  ?(active_graph="@default") ?(active_subject=J.null) ?active_prop ?(list:json_map ref option) element =
    Log.debug (fun m -> m "node_map_generation: active_graph=%S, active_subject=%a, active_prop=%S, element=%s"
       active_graph J.pp active_subject
         (Option.value ~default:"None" active_prop)
         (J.to_string element)
    );
  (match list with
   | None -> ()
   | Some map ->
       Log.debug (fun m -> m "node_map_generation list=[%a]" J.map_pp !map);
  );
  match element.data with
  | `List items -> (* 1) *)
      List.iter
      (fun item -> node_map_generation node_map ~active_graph
         ~active_subject ?active_prop ?list item)
        items
  | `Float _ | `Bool _ | `String _ | `Null ->
      error (Invalid_expanded_json element)
  | `Obj map ->
      (* 2) *)
      match get_graph node_map active_graph with
      | None -> ()
      | Some graph ->
          let on_subject_node f =
            match active_subject.data with
            | `Null -> failwith "Invalid expanded json (no usable subject node)"
            | `String sub -> f (graph_get_node graph sub)
            | _ -> error (Invalid_expanded_json active_subject)
          in
          (* 3) *)
          let map = match J.map_get map "@type" with
            | None -> map
            | Some v ->
                let items = J.values v in
                let items = List.map (fun item ->
                     if is_blank_node_id item then
                       json_gen_blank_node graph item
                     else
                       item) items
                in
                J.map_add_value map "@type" (J.list ?loc:v.loc items)
          in
          Log.debug (fun m -> m "node_map_generation: map = %a" J.map_pp map);
          let element = J.obj ?loc:element.loc map in
          match J.map_get map "@value" with
          | Some v -> (* 4) *)
              (match list with
               | None -> (* 4.1) *)
                   (
                    match active_prop with
                    | None ->
                        (* what to do is not specified but we should not get there
                           without active property *)
                        failwith "Invalid expanded json (no active prop)"
                    | Some prop ->
                        on_subject_node (fun subject_node ->
                           match SMap.find_opt prop !subject_node with
                           | None -> (* 4.1.1) *)
                               Log.debug (fun m -> m "node_map_generation 4.1.1)");
                               subject_node := SMap.add prop [element] !subject_node
                           | Some items -> (* 4.1.2) *)
                               if not (List.exists (fun item -> J.compare element item = 0) items) then
                                 (
                                  Log.debug (fun m -> m "node_map_generation 4.1.2, adding %s to subject_node @list)"
                                     (J.to_string element));
                                  subject_node := SMap.add prop (element :: items) !subject_node
                                 )
                               else
                                 Log.debug (fun m -> m "node_map_generation 4.1.2, not adding %s"
                                    (J.to_string element))
                        )
                   )
               | Some l -> (* 4.2) *)
                   Log.debug (fun m -> m "node_map_generation 4.2)");
                   match J.map_get !l "@list" with
                   | Some {data=`List items} -> l := J.map_add_value !l "@list" (J.list (items @ [element]))
                   | _ -> assert false
              )
          | _ ->
              match J.map_get map "@list" with
              | Some v -> (* 5) *)
                  (
                   (* 5.1) *)
                   let result = [ranged "@list", J.list []] in
                   let result = ref result in
                   (* 5.2) *)
                   node_map_generation node_map ~active_graph ~active_subject ?active_prop
                     ~list:result v;
                   Log.debug (fun m -> m "new result=%a" J.map_pp !result);
                   let result = J.obj !result in
                   match list with
                   | None -> (* 5.3) *)
                       (
                        match active_prop with
                        | None ->
                            (* what to do is not specified but we should not get there
                               without active property *)
                            failwith "Invalid expanded json (no active prop)"
                        | Some prop ->
                            on_subject_node (fun subject_node ->
                               let prop_v =
                                 match SMap.find_opt prop !subject_node with
                                 | None -> []
                                 | Some items -> items
                               in
                               subject_node := SMap.add prop (prop_v @ [result]) !subject_node
                            )
                       )
                   | Some l -> (* 5.4) *)
                       match J.map_get !l "@list" with
                       | Some {data=`List items} -> l := J.map_add_value !l "@list" (J.list (items @ [result]))
                       | _ -> assert false
                  )
              | None -> (* 6) *)
                  let map, id =
                    match J.map_get map "@id" with
                    | Some ({ data = `String s_id } as id) -> (* 6.1) *)
                        let map = J.map_remove_value map "@id" in
                        let id =
                          if is_blank_node_id id
                          then gen_blank_node graph id
                          else s_id
                        in
                        map, id
                    | Some {data=`Null} ->
                        let map = J.map_remove_value map "@id" in
                        map, gen_blank_node graph J.null
                    | None -> (* 6.2) *) map, gen_blank_node graph J.null
                    | Some _ ->
                        (* see https://github.com/w3c/json-ld-api/issues/480 *)
                        failwith "Invalid expanded json (@id not a string)"
                  in
                  Log.debug (fun m -> m "node_map_generation: new blank id %S" id);
                  (* 6.3) and 6.4) *)
                  let node = graph_get_node graph id in
                  Log.debug (fun m -> m "node_map_generation: node = %a" pp_node node);
                  let () =
                    match active_subject.data with
                    | `Obj  sub_map-> (* 6.5) *)
                        (match active_prop with
                         | None -> failwith "Invalid expanded json (no active prop)"
                         | Some prop ->
                             match SMap.find_opt prop !node with
                             | None -> (* 6.5.1) *)
                                 node := SMap.add prop [active_subject] !node
                             | Some items -> (* 6.5.2) *)
                                 if not (List.exists (fun item -> J.compare active_subject item = 0) items) then
                                   node := SMap.add prop (active_subject :: items) !node
                        )
                    | _ ->
                        match active_prop with
                        | None -> ()
                        | Some prop -> (* 6.6) *)
                            (* 6.6.1) *)
                            let reference = J.obj [ranged "@id", J.string id] in
                            Log.debug (fun m -> m "node_map_generation: 6.6.1 id=%s" id);
                            match list with
                            | None -> (* 6.6.2) *)
                                on_subject_node (fun subject_node ->
                                   match SMap.find_opt prop !subject_node with
                                   | None -> (* 6.6.2.1) *)
                                       subject_node := SMap.add prop [reference] !subject_node
                                   | Some items -> (* 6.6.2.2) *)
                                       if not (List.exists (fun item -> J.compare reference item = 0) items) then
                                         subject_node := SMap.add prop (reference :: items) !subject_node
                                )
                            | Some l -> (* 6.6.3) *)
                                match J.map_get !l "@list" with
                                | Some {data=`List items} ->
                                    l := J.map_add_value !l "@list" (J.list (items @ [reference]))
                                | _ -> assert false
                  in
                  (* 6.7) *)
                  let map =
                    match J.map_get map "@type" with
                    | None -> map
                    | Some v ->
                        let items = J.values v in
                        let node_type_items = match SMap.find_opt "@type" !node with
                          | None -> []
                          | Some l -> l
                        in
                        let node_type_items = List.fold_left (fun acc item ->
                             if List.exists (fun t -> J.compare t item = 0) node_type_items then
                               acc
                             else item :: acc)
                          items node_type_items
                        in
                        node := SMap.add "@type" (List.rev node_type_items) !node;
                        J.map_remove_value map "@type"
                  in
                  (* 6.8) *)
                  Log.debug (fun m -> m "node_map_generation: 6.8. node = %a" pp_node node);
                  Log.debug (fun m -> m "node_map_generation: 6.8. map = %a" J.map_pp map);
                  let map =
                    match J.map_get map "@index", SMap.find_opt "@index" !node with
                    | None, _ -> map
                    | Some v, None ->
                        node := SMap.add "@index" [v] !node;
                        J.map_remove_value map "@index"
                    | Some v_elt, Some v_node ->
                        (* as usual, spec don't care about types, we have
                           to make v_elt and v_node comparable *)
                        if List.compare J.compare [v_elt] v_node <> 0 then
                          error (Conflicting_indexes element)
                        else
                          map
                  in
                  (* 6.9) *)
                  let map =
                    match J.map_get map "@reverse" with
                    | None -> map
                    | Some v ->
                        (* 6.9.1) *)
                        let referenced_node = [ranged "@id", J.string id] in
                        (* 6.9.2) (useless) and 6.9.3 *)
                        match v.data with
                        | `Obj prop_values ->
                            List.iter (fun (prop, l) ->
                               List.iter (fun value ->
                                  (* 6.9.3.1.1) *)
                                  node_map_generation node_map ~active_graph
                                    ~active_subject:(J.obj referenced_node)
                                    ~active_prop:prop.data
                                    value;
                               ) (J.values l)
                            ) prop_values;
                            (* 6.9.4) *)
                            J.map_remove_value map "@reverse"
                        | _ -> failwith "Invalid expanded json (@reverse value is not a map)"
                  in
                  (* 6.10) *)
                  let map =
                    match J.map_get map "@graph" with
                    | None -> map
                    | Some v ->
                        node_map_generation node_map ~active_graph:id v;
                        J.map_remove_value map "@graph"
                  in
                  (* 6.11) *)
                  let map =
                    match J.map_get map "@included" with
                    | None -> map
                    | Some v ->
                        node_map_generation node_map ~active_graph v;
                        J.map_remove_value map "@included"
                  in
                  (* 6.12) *)
                  Log.debug (fun m -> m "node_map_generation: 6.12 map = %a" J.map_pp map);
                  let map = sort_map map in
                  List.iter (fun (prop, v) ->
                     let prop_json = J.string prop.data in
                     (* 6.12.1) *)
                     let prop_str =
                       if is_blank_node_id prop_json then
                         gen_blank_node graph prop_json
                       else prop.data
                     in
                     (* 6.12.2) *)
                     if not (SMap.mem prop_str !node) then node := SMap.add prop_str [] !node;
                     (* 6.12.3) *)
                     node_map_generation node_map ~active_graph
                       ~active_subject:(J.string id) ~active_prop:prop_str v
                  )
                    map