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

(** Serialization to JSON-LD. *)

open T

type 'a smap = { mutable map : 'a SMap.t }
let smap_empty () = { map = SMap.empty }
let smap_singleton entry v = { map = SMap.singleton entry v }
let smap_find e m = SMap.find_opt e m.map
let smap_add e v m = m.map <- SMap.add e v m.map

type AnyMap.k +=
| T of Rdf.Term.term
| I of Iri.t
| B of Rdf.Term.blank_id
| N of string

let () =
  let c a b =
    match a, b with
    | T t1, T t2 -> Some (Rdf.Term.compare t1 t2)
    | T _, _ -> Some (-1)
    | _, T _ -> Some (1)
    | I i1, I i2 -> Some (Iri.compare i1 i2)
    | I _, _ -> Some (-1)
    | _, I _ -> Some 1
    | B id1, B id2 -> Some (Stdlib.compare id1 id2)
    | B _, _ -> Some (-1)
    | _, B _ -> Some 1
    | N s1, N s2 -> Some (String.compare s1 s2)
    | N _ , _ -> Some (-1)
    | _, N _ -> Some 1
    | _ -> None
  in
  AnyMap.register_compare c

type 'a map =  { mutable amap : 'a AnyMap.t }
let map_empty () = { amap = AnyMap.empty }
let map_singleton t v = { amap = AnyMap.singleton t v }
let map_find t m = AnyMap.find_opt t m.amap
let map_add t v m = m.amap <- AnyMap.add t v m.amap

type node = J.json list map

let j_iri iri = J.string (Iri.to_string iri)
let j_term = function
| Rdf.Term.Iri iri -> j_iri iri
| Blank -> assert false
| Blank_ id -> J.string ("_:"^(Rdf.Term.string_of_blank_id id))
| Literal _ -> assert false

(* https://www.w3.org/TR/json-ld11-api/#rdf-to-object-conversion *)
let rdf_to_object options value =
  match value with
  | Rdf.Term.Iri _ | Blank_ _ -> (* 1) *)
      T.smap_to_json (smap_singleton "@id" (j_term value)).map
  | Blank -> assert false
  | Literal lit -> (* 2) *)
      let result = smap_empty () in
      (* Spec algorithm does not tell what to do when we should use
         native types but the value cannot be converted to native json;
         we choose to use steps 2.5-2.8 in this case. *)
      let conv_type =
        if options.use_native_types then
          ( (* 2.4) *)
           match lit.lit_type with
           | Some iri when Iri.equal iri Rdf.Rdf_.xsd_string ->
               (* 2.4.1) *)
               Some (J.string lit.lit_value, None)
           | Some iri when Iri.equal iri Rdf.Rdf_.xsd_boolean ->
               Some
                 (match lit.lit_value with
                  | "true" -> J.bool true, None
                  | "false" -> J.bool false, None
                  | _ -> J.string lit.lit_value, Some iri
                 )
           | Some iri when Iri.equal iri Rdf.Rdf_.xsd_integer
                 || Iri.equal iri Rdf.Rdf_.xsd_double ->
               (match float_of_string lit.lit_value with
                | exception _ -> None
                | f -> Some (J.float f, None)
               )
           | _ -> None
          )
        else
          None
      in
      let (conv, type_) =
        match conv_type with
        | Some (json, t) -> (json, Option.map Iri.to_string t)
        | None ->
            match lit.lit_type with
            | Some iri when Iri.equal iri Rdf.Rdf_.dt_JSON &&
                options.processing_mode <> "json-ld-1.0" ->
                (
                 (* 2.5) *)
                 match J.from_string lit.lit_value with
                 | Ok json -> (json, Some "@json")
                 | Error _ -> error (Invalid_json_literal lit.lit_value)
                )
            | Some iri when options.rdf_direction = Some I18n_datatype
                  && Rdf.Utf8.utf8_is_prefix (Iri.to_string iri) T.i18n_ns ->
                (* 2.6) *)
                (match Iri.fragment iri with
                 | None -> ()
                 | Some frag ->
                     (match Rdf.Utf8.utf8_strbefore frag "_" with
                      | "" -> ()
                      | tag -> smap_add "@language" (J.string tag) result
                     );
                     (match Rdf.Utf8.utf8_strafter frag "_" with
                      | "" -> ()
                      | s -> smap_add "@direction" (J.string s) result
                     )
                );
                (J.string lit.lit_value, None)
            | _ ->
                match lit.lit_language with
                | Some tag -> (* 2.7) *)
                    smap_add "@language" (J.string tag) result;
                    (J.string lit.lit_value, None)
                | None -> (* 2.8) *)
                    let type_ = match lit.lit_type with
                      | Some iri when Iri.equal iri Rdf.Rdf_.xsd_string -> None
                      | Some iri -> Some (Iri.to_string iri)
                      | None -> None
                    in
                    (J.string lit.lit_value, type_)
      in
      (* 2.9) *)
      smap_add "@value" conv result ;
      (* 2.10) *)
      (match type_ with
       | None -> ()
       | Some s -> smap_add "@type" (J.string s) result);
      T.smap_to_json result.map

(*
let of_rdf options dataset =
  (* 1) *)
  let default_graph = map_empty () in
  (* 2) *)
  let graph_map = smap_singleton "@default" default_graph in
  (* 3) *)
  let _referenced_once = smap_empty in
  (* 4) *)
  let compound_literal_subjects = smap_empty () in
  (* 5) *)
  let f_graph name graph =
    (* 5.1) *)
    let name = Option.value ~default:"@default"
      (Option.map Rdf.Ds.string_of_name name)
    in
    (* 5.2) and 5.5) *)
    let node_map =
      match smap_find name graph_map with
      | Some x -> x
      | None ->
          let x = map_empty () in
          smap_add name x graph_map ;
          x
    in
    (* 5.3) and 5.6) *)
    let compound_map =
      match smap_find name compound_literal_subjects with
      | Some x -> x
      | None ->
          let map = map_empty () in
          smap_add name map compound_literal_subjects;
          map
    in
    (* 5.4) *)
    if name <> "@default" then
      (match map_find (N name) default_graph with
       | Some _ -> ()
       | None ->
           let map = map_singleton (N "@id") [J.string name] in
           map_add (N name) map default_graph
      );
    (* 5.7) *)
    let f_triple (sub, pred, obj) =
      (* 5.7.1) and 5.7.2) *)
      let node : node = match map_find (T sub) node_map with
        | Some n -> n
        | None ->
            let node = map_singleton (N "@id") [j_term sub] in
            map_add (T sub) node node_map;
            node
      in
      (* 5.7.3) *)
      (match options.rdf_direction with
       | Some Compound_literal when Iri.equal pred Rdf.Rdf_.direction ->
           map_add (T sub) true compound_map
       | _ -> ()
      );
      (* 5.7.4) *)
      (match obj with
       | Rdf.Term.Iri _ | Blank_ _ ->
           (
            match map_find (T obj) node_map with
            | Some _ -> ()
            | None ->
                let node = map_singleton (N "@id") [j_term obj] in
                map_add (T obj) node node_map
           )
       | _ -> ()
      );
      match obj with
      | Iri _ | Blank_ _ when
          Iri.equal pred Rdf.Rdf_.type_ && not options.use_rdf_type ->
          (* 5.7.5) *)
          (let k = N "@type" in
           match map_find k node with
           | None -> map_add k [j_term obj] node
           | Some l when List.exists (J.equal (j_term obj)) l -> ()
           | Some l -> map_add k (l @ [j_term obj]) node
          )
      | _ -> (* 5.7.6) *)
          let value = rdf_to_object options obj in
          ( (* 5.7.7) and 5.7.8) *)
           match map_find (T (Iri pred)) node with
           | None ->
               map_add (T (Iri pred)) [value] node
           | Some l ->
               if not (List.exists (J.equal value) l) then
                 map_add (T (Iri pred)) (l@[value]) node
          );
(*          match obj with
          | Iri iri when Iri.equal iri Rdf.Rdf_.nil ->
              (* 5.7.9) *)
*)
            ()
    in
    List.iter f_triple (graph.Rdf.Graph.find ())
  in
  Rdf.Ds.iter f_graph
*)

let from_rdf options dataset =
  let f_triple (_, pred, obj) =
    let obj = rdf_to_object options obj in
    J.ranged (Iri.to_string pred), obj
  in
  let f_subject sub triples =
    let id = j_term sub in
    J.obj 
      ( (J.ranged "@id", id) :: (List.map f_triple triples) )
  in
  let f_graph acc name g =
    let subjects = g.Rdf.Graph.subjects () in
    let triples = List.map
      (fun sub -> f_subject sub (g.Rdf.Graph.find ~sub ())) subjects
    in
    match name with
    | None-> acc @ triples
    | Some name ->
        let graph = [J.ranged "@graph", J.list triples] in
        let fields =
          let s = match name with
            | `I iri -> Iri.to_string iri
            | `B id -> "_:"^(Rdf.Term.string_of_blank_id id)
          in
          (J.ranged "@id", (J.string s)) :: graph
        in
        (J.obj fields) :: acc
  in
  let graphs = Rdf.Ds.fold f_graph [] dataset in
  J.list graphs

let nil_term = Rdf.Term.Iri Rdf.Rdf_.nil

let from_rdf_root options g root =
  let group_by_pred l =
    List.fold_left
      (fun acc (_,pred,obj) ->
         match Iri.Map.find_opt pred acc with
         | None -> Iri.Map.add pred [obj] acc
         | Some objs -> Iri.Map.add pred (obj::objs) acc
      )
      Iri.Map.empty l
  in
  let rec f_triple seen (pred,objs) =
    let objs = List.map (obj seen) objs in
    let obj = match objs with
      | [] -> assert false
      | [obj] -> obj
      | list -> J.list list
    in
    J.ranged (Iri.to_string pred), obj
  and obj seen sub =
    match sub with
    | Rdf.Term.(Iri _ | Blank_ _) when not (Rdf.Term.TSet.mem sub seen) ->
        if Rdf.Term.equal sub nil_term then
          J.list []
        else
          (
           let seen = Rdf.Term.TSet.add sub seen in
           match Rdf.Graph.to_list g sub with
           | [] ->
               let triples = g.Rdf.Graph.find ~sub () in
               let grouped_triples = group_by_pred triples in
               J.obj
                 ((J.ranged "@id", j_term sub) ::
                  (List.map (f_triple seen) (Iri.Map.bindings grouped_triples))
                 )
           | list ->
              J.list (List.map (obj seen) list)
          )
    | _ -> rdf_to_object options sub
  in
  obj Rdf.Term.TSet.empty root