Source file ppx_rdf.ml

(*********************************************************************************)
(*                OCaml-RDF                                                      *)
(*                                                                               *)
(*    Copyright (C) 2012-2021 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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** OCaml syntax extension to check syntax of Sparql queries at compile time. *)

module Re = Str


exception Error of Location.t * string

let mkloc = Location.mkloc
let mknoloc = Location.mknoloc

let () =
  Location.register_error_of_exn (fun exn ->
    match exn with
    | Error (loc, msg) -> Some (Location.error ~loc msg)
    | _ -> None)


let longident_of_string ?loc str =
  let b = Lexing.from_string str in
  let b =
    match loc with
    | None -> b
    | Some loc ->
        let p = loc.Location.loc_start in
        { b with Lexing.lex_start_p = p; lex_curr_p = p }
  in
  Parse.longident b


let lid_sprintf = Location.mknoloc (longident_of_string "Printf.sprintf")
let lid_sparql_error = Location.mknoloc (longident_of_string "Rdf.Sparql.Error")
let lid_sparql_parse_error = Location.mknoloc (longident_of_string "Rdf.Sparql.Parse_error")

open Ppxlib
open Ast_helper

module Location = Ppxlib_ast__Import.Location

let sparql_node = "sparql"
let re_fmt = Re.regexp
  "\\([^%]?\\)%\\([-+0# ]*[0-9]*\\(\\.[0-9]+\\)?[lLn]?\\(\\({term}\\)\\|[!%@,diXxoSsCcFfEeGgBbat]\\)\\)"

let check_query_fmt loc fmt =
  let f s =
    let res =
      match Re.matched_group 4 s with
        "{term}" -> "<http://foo/bar>"
      | "d" | "i" -> "0"
      | "s" -> "string"
      | "S" -> "\"String\""
      | "o" -> "0"
      | "c" -> "c"
      | "C" -> "'C'"
      | "f" -> "0.0"
      | "F" | "E" | "e" | "G" | "g" -> "0.0e-0"
      | "X" -> "ABCD123"
      | "x" -> "abcd123"
      | "B" | "b" -> "true"
      | "a" -> "\"%a\""
      | "t" -> "\"%t\""
      | "!" -> ""
      | "@" -> "@"
      | "%" -> "%"
      | "," -> ""
      | _ -> "%"^(Re.matched_group 2 s)
    in
    (try Re.matched_group 1 s with _ -> "")^res
  in
  let q = Re.global_substitute re_fmt f fmt in
  try ignore(Rdf.Sparql.query_from_string q)
  with Rdf.Sparql.Error e ->
      let q = Re.global_replace (Re.regexp_string "\n") "\n  " q in
      let msg = Printf.sprintf "Checking syntax of query\n  %s\n%s" q (Rdf.Sparql.string_of_error e) in
      raise (Error (loc, msg))


let gen_code ~loc ~attrs fmt args =
  let args =
    (Nolabel, Exp.constant ~loc (Pconst_string (fmt, loc, None))) :: args
  in
  let f =
    let e =
      Exp.apply ~loc (Exp.ident (mknoloc (longident_of_string "Rdf.Sparql.query_from_string")))
        [
          Nolabel, Exp.ident(mknoloc (longident_of_string "_q")) ;
        ]
    in
    let case =
      let pat = Pat.construct lid_sparql_error
        (Some (Pat.construct lid_sparql_parse_error
          (Some (Pat.tuple [ Pat.var (mknoloc "eloc") ; Pat.var (mknoloc "msg")]))
         ))
      in
      let e =
        Exp.let_ Nonrecursive
          [ Vb.mk (Pat.var (mknoloc "msg"))
            (Exp.apply (Exp.ident lid_sprintf)
             [ Nolabel, Exp.constant (Pconst_string ("%s\nin %s", Location.none, None)) ;
               Nolabel, Exp.ident (mknoloc (longident_of_string "msg")) ;
               Nolabel, Exp.ident (mknoloc (longident_of_string "_q")) ;
             ]
            )
          ]
          (Exp.apply (Exp.ident (mknoloc (longident_of_string "raise")))
           [ Nolabel,
             Exp.construct lid_sparql_error
               (Some (Exp.construct lid_sparql_parse_error
                 (Some (Exp.tuple [
                     Exp.ident (mknoloc (longident_of_string  "eloc")) ;
                     Exp.ident (mknoloc (longident_of_string  "msg")) ;
                   ]))
                ))
           ]
          )
      in
      Exp.case pat e
    in
    let body = Exp.try_ ~loc ~attrs e [case] in
    Exp.fun_ Nolabel None (Pat.var (mknoloc "_q")) body
  in
  Exp.apply ~loc ~attrs
    (Exp.ident (mknoloc (longident_of_string "Printf.ksprintf")))
    ((Nolabel, f) :: args)
;;

let expand ~loc ~path e =
  match
    match e.pexp_desc with
    | Pexp_constant (Pconst_string (s, _, _)) -> Some (e.pexp_loc, s, [])
    | Pexp_apply ({ pexp_desc = Pexp_constant (Pconst_string (s, _, _)) ; pexp_loc}, args) ->
        Some (pexp_loc, s, args)
    | _ -> None
  with
  | None -> Location.raise_errorf ~loc:e.pexp_loc "Invalid payload for sparql extension"
  | Some (loc, fmt, args) ->
      check_query_fmt loc fmt ;
      let terms = ref [] in
      let n = ref (-1) in
      let f s =
        incr n;
        let g = Re.matched_group 4 s in
        match g with
          "{term}" -> terms := !n :: !terms ; (Re.matched_group 1 s)^"%s"
        | _ -> Re.matched_string s
      in
      let fmt = Re.global_substitute re_fmt f fmt in
      let rec iter i = function
        [] -> []
      | (l, e) :: q when List.mem i !terms ->
                    let e = Exp.apply
            (Exp.ident (mknoloc (longident_of_string "Rdf.Term.string_of_term")))
              [ Nolabel, e ]
          in
          (l, e) :: iter (i+1) q
      | x :: q -> x :: iter (i+1) q
      in
      let args = iter 0 args in
      gen_code ~loc: e.pexp_loc ~attrs: e.pexp_attributes fmt args


let my_extension =
  Extension.declare
    sparql_node
    Extension.Context.expression
    Ast_pattern.(single_expr_payload __)
    expand

let rule = Ppxlib.Context_free.Rule.extension my_extension

let () =
  Driver.register_transformation
    ~rules:[rule]
    sparql_node