;;; rdf-turtle.el --- Turtle reader: tree-sitter-turtle parse tree -> rdf-model quads  -*- lexical-binding: t; -*-

;; Author: Eric Prud'hommeaux <eric@w3.org>
;; Assisted-by: Claude:claude-sonnet-4-6
;; Package-Requires: ((emacs "29.1") (rdf-core "0.1.0") (rdf-model "0.1.0") (rdf-store "0.1.0"))
;; Keywords: languages
;; URL: https://github.com/ericprud/shexc-mode-for-emacs
;; SPDX-License-Identifier: MIT

;;; Commentary:

;; Walks a `tree-sitter-turtle' parse tree (the same grammar
;; `turtle-ts-mode' uses) into `rdf-model' quads/an `rdf-store' --
;; deliberately independent of `turtle-ts-mode.el' itself, so batch
;; consumers (tests, future validators) don't need to load any editing
;; machinery (font-lock, indent, hideshow) just to parse a file.  The
;; grammar's `treesit-language-source-alist' registration lives in
;; `rdf-core.el', shared by both this file and `turtle-ts-mode.el'.
;;
;; Scope: the default graph only (no `GRAPH'/TriG -- confirmed unneeded
;; against the full shexTest schemas/*.ttl corpus, see rdf-turtle-tests.el).
;; `( ... )' collections become the standard RDF list encoding
;; (`rdf:first'/`rdf:rest'/`rdf:nil'), matching how real Turtle->RDF
;; conversion (and the ShExR `.ttl' fixtures' own collections) works.
;;
;; This file is currently bundled inside the `shexc-ts-mode' MELPA
;; package rather than shipped as its own package -- see the README's
;; "Packaging" section.  Named after the package it's meant to become.

;;; Code:

(require 'cl-lib)
(require 'treesit)
(require 'url-expand)
(require 'rdf-core)
(require 'rdf-model)
(require 'rdf-store)

(declare-function treesit-parser-create "treesit.c")
(declare-function treesit-buffer-root-node "treesit.c")
(declare-function treesit-node-type "treesit.c")
(declare-function treesit-node-text "treesit.c")
(declare-function treesit-node-child "treesit.c")
(declare-function treesit-node-child-count "treesit.c")
(declare-function treesit-node-child-by-field-name "treesit.c")

;;; Vocabulary constants

(defconst rdf-turtle--rdf-ns "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(defconst rdf-turtle--xsd-ns "http://www.w3.org/2001/XMLSchema#")

(defun rdf-turtle--rdf (local)
  (rdf-model-named-node-create :value (concat rdf-turtle--rdf-ns local)))

(defun rdf-turtle--xsd (local)
  (rdf-model-named-node-create :value (concat rdf-turtle--xsd-ns local)))

;;; Parse context

(cl-defstruct (rdf-turtle--ctx (:constructor rdf-turtle--ctx-create))
  (prefixes (make-hash-table :test #'equal))
  (base nil)
  (store nil)
  ;; Hash table (`equal' test), filled in by `rdf-turtle--process-triples'
  ;; when non-nil -- see `rdf-turtle-parse-buffer''s POSITIONS argument.
  (positions nil))

;;; String/IRI/local-name unescaping
;;
;; IRIREFs allow only UCHAR escapes (`\uXXXX'/`\UXXXXXXXX'); quoted
;; string literals allow both UCHAR and ECHAR (`\t\n\r\b\f\"\'\\').
;; PN_LOCAL allows `\'-escaping a fixed set of punctuation characters
;; (PN_LOCAL_ESC) to use them literally in a local name -- unlike
;; UCHAR/ECHAR, percent-encoded (`%XX') sequences in PN_LOCAL are *not*
;; decoded; they pass through verbatim as part of the resulting IRI.

(defconst rdf-turtle--uchar-rx "\\\\\\(?:u\\([0-9a-fA-F]\\{4\\}\\)\\|U\\([0-9a-fA-F]\\{8\\}\\)\\)")

(defun rdf-turtle--unescape-uchar (text)
  ;; `case-fold-search' would make the regex's lowercase `u' alternative
  ;; also match an uppercase `U' -- so a `\Uxxxxxxxx' (8-hex) escape
  ;; would be misparsed as `\u' (4-hex) plus four leftover literal
  ;; characters, silently corrupting the decoded codepoint.
  (let ((case-fold-search nil))
    (replace-regexp-in-string
     rdf-turtle--uchar-rx
     (lambda (m)
       (save-match-data
         (string-match rdf-turtle--uchar-rx m)
         (string (string-to-number (or (match-string 1 m) (match-string 2 m)) 16))))
     text t t)))

(defconst rdf-turtle--echar-or-uchar-rx
  "\\\\\\(?:u\\([0-9a-fA-F]\\{4\\}\\)\\|U\\([0-9a-fA-F]\\{8\\}\\)\\|\\(.\\)\\)")

(defun rdf-turtle--unescape-string (text)
  ;; See `rdf-turtle--unescape-uchar' on why `case-fold-search' must be
  ;; nil here too.
  (let ((case-fold-search nil))
    (replace-regexp-in-string
     rdf-turtle--echar-or-uchar-rx
     (lambda (m)
       (save-match-data
         (string-match rdf-turtle--echar-or-uchar-rx m)
         (cond
          ((match-string 1 m) (string (string-to-number (match-string 1 m) 16)))
          ((match-string 2 m) (string (string-to-number (match-string 2 m) 16)))
          (t (pcase (aref (match-string 3 m) 0)
               (?t "\t") (?n "\n") (?r "\r") (?b "\b") (?f "\f")
               (?\" "\"") (?\' "'") (?\\ "\\")
               (c (string c)))))))
     text t t)))

(defun rdf-turtle--unescape-pn-local (text)
  (replace-regexp-in-string "\\\\\\(.\\)" "\\1" text t))

(defun rdf-turtle--strip-quotes (text)
  "Strip a `string' node's surrounding quotes (1 or 3 of `\"'/`\\='')."
  (let ((long (or (string-prefix-p "\"\"\"" text) (string-prefix-p "'''" text))))
    (substring text (if long 3 1) (- (length text) (if long 3 1)))))

;;; Tree-sitter helpers

(defun rdf-turtle--child-of-type (node type)
  "First named child of NODE whose type is TYPE, or nil."
  (let ((n (treesit-node-child-count node t)) (i 0) (found nil))
    (while (and (< i n) (not found))
      (let ((c (treesit-node-child node i t)))
        (when (equal (treesit-node-type c) type) (setq found c)))
      (setq i (1+ i)))
    found))

(defun rdf-turtle--children-of-types (node types)
  "All named children of NODE whose type is in TYPES, in order."
  (let ((n (treesit-node-child-count node t)) (i 0) (acc nil))
    (while (< i n)
      (let ((c (treesit-node-child node i t)))
        (when (member (treesit-node-type c) types) (push c acc)))
      (setq i (1+ i)))
    (nreverse acc)))

;;; IRI/prefix resolution

(defun rdf-turtle--resolve-iri (ctx text)
  (let ((absolute (rdf-turtle--unescape-uchar text)))
    (if (rdf-turtle--ctx-base ctx)
        (url-expand-file-name absolute (rdf-turtle--ctx-base ctx))
      absolute)))

(defun rdf-turtle--iri-reference-term (ctx node)
  (let* ((text (treesit-node-text node t))
         (inner (substring text 1 (1- (length text)))))
    (rdf-model-named-node-create :value (rdf-turtle--resolve-iri ctx inner))))

(defun rdf-turtle--namespace-prefix-name (namespace-node)
  (let ((pfx (rdf-turtle--child-of-type namespace-node "pn_prefix")))
    (if pfx (treesit-node-text pfx t) "")))

(defun rdf-turtle--prefixed-name-term (ctx node)
  (let* ((namespace (rdf-turtle--child-of-type node "namespace"))
         (pn-local (rdf-turtle--child-of-type node "pn_local"))
         (prefix-name (rdf-turtle--namespace-prefix-name namespace))
         (base-iri (gethash prefix-name (rdf-turtle--ctx-prefixes ctx)))
         (local (if pn-local (rdf-turtle--unescape-pn-local (treesit-node-text pn-local t)) "")))
    (unless base-iri
      (error "rdf-turtle: undeclared prefix `%s:'" prefix-name))
    (rdf-model-named-node-create :value (concat base-iri local))))

;;; Literals

(defun rdf-turtle--rdf-literal-term (node)
  (let* ((value-node (treesit-node-child-by-field-name node "value"))
         (lexical (rdf-turtle--unescape-string (rdf-turtle--strip-quotes (treesit-node-text value-node t))))
         (lang-node (rdf-turtle--child-of-type node "lang_tag"))
         (datatype-node (rdf-turtle--child-of-type node "iri_reference")))
    (unless datatype-node
      (setq datatype-node (rdf-turtle--child-of-type node "prefixed_name")))
    (cond
     (lang-node
      (rdf-model-literal-create
       :value lexical
       :language (substring (treesit-node-text lang-node t) 1) ; drop leading "@"
       :datatype (rdf-turtle--rdf "langString")))
     (datatype-node
      ;; datatype-node here is a bare iri_reference/prefixed_name (not yet
      ;; resolved against prefixes/base) -- caller resolves via rdf-turtle--term.
      (rdf-model-literal-create :value lexical :language nil :datatype datatype-node))
     (t
      (rdf-model-literal-create :value lexical :language nil :datatype (rdf-turtle--xsd "string"))))))

;;; Term resolution (dispatches by node type)

(defun rdf-turtle--term (ctx node)
  "Resolve NODE (any object/subject-position node) to an `rdf-model' term.
May have side effects on CTX's store (collections, blank-node property
lists mint fresh blank nodes and emit quads about them)."
  (pcase (treesit-node-type node)
    ("iri_reference" (rdf-turtle--iri-reference-term ctx node))
    ("prefixed_name" (rdf-turtle--prefixed-name-term ctx node))
    ("blank_node_label"
     (rdf-model-blank-node-create :value (substring (treesit-node-text node t) 2)))
    ("anon" (rdf-model-blank-node-create :value (symbol-name (cl-gensym "anon"))))
    ("boolean_literal"
     (rdf-model-literal-create :value (treesit-node-text node t) :datatype (rdf-turtle--xsd "boolean")))
    ("integer"
     (rdf-model-literal-create :value (treesit-node-text node t) :datatype (rdf-turtle--xsd "integer")))
    ("decimal"
     (rdf-model-literal-create :value (treesit-node-text node t) :datatype (rdf-turtle--xsd "decimal")))
    ("double"
     (rdf-model-literal-create :value (treesit-node-text node t) :datatype (rdf-turtle--xsd "double")))
    ("rdf_literal"
     ;; If :datatype is still a raw tree-sitter node (set by
     ;; rdf-turtle--rdf-literal-term when an explicit `^^' datatype was
     ;; present), resolve it now via the ordinary term resolver, so
     ;; prefix/base lookups apply.
     (let* ((lit (rdf-turtle--rdf-literal-term node))
            (dt (rdf-model-literal-datatype lit)))
       (when (treesit-node-p dt)
         (setf (rdf-model-literal-datatype lit) (rdf-turtle--term ctx dt)))
       lit))
    ("collection" (rdf-turtle--collection-term ctx node))
    ("blank_node_property_list" (rdf-turtle--blank-node-property-list-term ctx node))
    (other (error "rdf-turtle: unexpected term node type `%s'" other))))

(defun rdf-turtle--collection-term (ctx node)
  (let* ((object-collection (rdf-turtle--child-of-type node "object_collection"))
         (items (if object-collection
                    (rdf-turtle--children-of-types
                     object-collection
                     '("anon" "blank_node_label" "blank_node_property_list" "boolean_literal"
                       "collection" "decimal" "double" "integer" "iri_reference"
                       "prefixed_name" "rdf_literal"))
                  nil)))
    (if (null items)
        (rdf-turtle--rdf "nil")
      (let ((store (rdf-turtle--ctx-store ctx))
            (head nil) (prev nil))
        (dolist (item-node items)
          (let* ((item-term (rdf-turtle--term ctx item-node))
                 (cell (rdf-model-blank-node-create :value (symbol-name (cl-gensym "list")))))
            (unless head (setq head cell))
            (rdf-model-dataset-add
             store (rdf-model-quad-create :subject cell :predicate (rdf-turtle--rdf "first") :object item-term))
            (when prev
              (rdf-model-dataset-add
               store (rdf-model-quad-create :subject prev :predicate (rdf-turtle--rdf "rest") :object cell)))
            (setq prev cell)))
        (rdf-model-dataset-add
         store (rdf-model-quad-create :subject prev :predicate (rdf-turtle--rdf "rest") :object (rdf-turtle--rdf "nil")))
        head))))

(defun rdf-turtle--blank-node-property-list-term (ctx node)
  (let ((bnode (rdf-model-blank-node-create :value (symbol-name (cl-gensym "anon"))))
        (property-list (rdf-turtle--child-of-type node "property_list")))
    (when property-list
      (rdf-turtle--process-property-list ctx bnode property-list))
    bnode))

;;; External term keys
;;
;; A subject's string key, in the same format rudof/`shex_ast' itself
;; prints a `Node' as (bare IRI; blank node prefixed with "_:") -- so a
;; caller matching ShEx validation-result node strings (rudof's own
;; `Node::to_string()'/`Object''s `Display') back to this table's keys
;; needs no extra translation in either direction. Only ever called on
;; subject-position terms (named/blank node), never literals.

(defun rdf-turtle-term-key (term)
  "External string key for TERM (an `rdf-model-named-node' or
`rdf-model-blank-node'), matching rudof's own `Node' string form."
  (cond
   ((rdf-model-named-node-p term) (rdf-model-named-node-value term))
   ((rdf-model-blank-node-p term) (concat "_:" (rdf-model-blank-node-value term)))
   (t (signal 'wrong-type-argument (list 'rdf-model-named-node-or-blank-node-p term)))))

;;; Statement processing

(defun rdf-turtle--predicate-term (ctx node)
  (if (= (treesit-node-child-count node t) 0)
      (rdf-turtle--rdf "type") ; bare `a'
    (rdf-turtle--term ctx (treesit-node-child node 0 t))))

(defun rdf-turtle--process-property-list (ctx subject property-list-node)
  (dolist (property (rdf-turtle--children-of-types property-list-node '("property")))
    (let* ((predicate-node (rdf-turtle--child-of-type property "predicate"))
           (predicate (rdf-turtle--predicate-term ctx predicate-node))
           (object-list-node (rdf-turtle--child-of-type property "object_list"))
           (object-nodes (rdf-turtle--children-of-types
                           object-list-node
                           '("anon" "blank_node_label" "blank_node_property_list" "boolean_literal"
                             "collection" "decimal" "double" "integer" "iri_reference"
                             "prefixed_name" "rdf_literal"))))
      (dolist (object-node object-nodes)
        (rdf-model-dataset-add
         (rdf-turtle--ctx-store ctx)
         (rdf-model-quad-create :subject subject :predicate predicate
                                 :object (rdf-turtle--term ctx object-node)))))))

(defun rdf-turtle--process-triples (ctx node)
  (let* ((subject-node (rdf-turtle--child-of-type node "subject"))
         (bnpl-node (rdf-turtle--child-of-type node "blank_node_property_list"))
         (property-list-node (rdf-turtle--child-of-type node "property_list"))
         (subject (if subject-node
                      (rdf-turtle--term ctx (treesit-node-child subject-node 0 t))
                    (rdf-turtle--blank-node-property-list-term ctx bnpl-node))))
    ;; Exactly one of subject-node/bnpl-node is present per the grammar;
    ;; either way, a top-level property_list here is this triples
    ;; statement's own predicateObjectList about SUBJECT -- for the
    ;; bnpl case this is the *additional* predicateObjectList after
    ;; `[...]' (its own internal properties were already processed
    ;; inside rdf-turtle--blank-node-property-list-term).
    (when property-list-node
      (rdf-turtle--process-property-list ctx subject property-list-node))
    ;; A bnpl-only subject (`[ ... ] .') has no external label a ShEx
    ;; ShapeMap/validation result could ever name, so there is nothing
    ;; useful to record a position for -- only subject-node occurrences
    ;; (named or `_:label'-led) go in the table.
    (when (and subject-node (rdf-turtle--ctx-positions ctx))
      (let ((key (rdf-turtle-term-key subject))
            (span (cons (treesit-node-start subject-node) (treesit-node-end subject-node))))
        (puthash key (cons span (gethash key (rdf-turtle--ctx-positions ctx)))
                 (rdf-turtle--ctx-positions ctx))))))

(defun rdf-turtle--process-directive (ctx node)
  (let ((kind (treesit-node-type (treesit-node-child node 0 t))))
    (pcase kind
      ((or "prefix_id" "sparql_prefix")
       (let* ((directive (treesit-node-child node 0 t))
              (namespace (rdf-turtle--child-of-type directive "namespace"))
              (iri-node (rdf-turtle--child-of-type directive "iri_reference"))
              (prefix-name (rdf-turtle--namespace-prefix-name namespace))
              (iri-text (treesit-node-text iri-node t)))
         (puthash prefix-name
                  (rdf-turtle--resolve-iri ctx (substring iri-text 1 (1- (length iri-text))))
                  (rdf-turtle--ctx-prefixes ctx))))
      ((or "base" "sparql_base")
       (let* ((directive (treesit-node-child node 0 t))
              (iri-node (rdf-turtle--child-of-type directive "iri_reference"))
              (iri-text (treesit-node-text iri-node t)))
         (setf (rdf-turtle--ctx-base ctx)
               (rdf-turtle--resolve-iri ctx (substring iri-text 1 (1- (length iri-text))))))))))

(defun rdf-turtle--walk-document (ctx root)
  (dolist (statement (rdf-turtle--children-of-types root '("statement")))
    (let ((child (treesit-node-child statement 0 t)))
      (pcase (treesit-node-type child)
        ("directive" (rdf-turtle--process-directive ctx child))
        ("triples" (rdf-turtle--process-triples ctx child))))))

;;; Public API

(defun rdf-turtle-parse-buffer (&optional store positions base)
  "Parse the current buffer's Turtle content into STORE (a new `rdf-store'
if nil) and return it.

POSITIONS, if non-nil, is a hash table (`equal' test) that this function
fills with subject `rdf-turtle-term-key' -> list of `(START . END)' buffer
positions, one entry per triples-statement subject occurrence in the
buffer (so a caller validating *this* buffer can map a ShEx validation
result's node string back to where it's actually asserted) -- meaningless
for any buffer other than the one actually being parsed, so unlike STORE
this is never useful from `rdf-turtle-parse-string'/`-file', which parse
inside a throwaway `with-temp-buffer'.

BASE, if non-nil, is the base IRI in effect *before* the buffer's own
text -- RFC 3986's \"base URI from the encapsulating entity\" (the
document's own retrieval URI, or the manifest a snippet was embedded
in): relative IRIs resolve against it, and a `BASE <...>' directive in
the text overrides it from that point on (itself resolved against it
first, if relative).  With BASE nil (the historical behavior),
relative IRIs stay relative until some directive says otherwise."
  (let ((ctx (rdf-turtle--ctx-create :store (or store (rdf-store-create)) :positions positions
                                     :base base)))
    (treesit-parser-create 'turtle)
    (rdf-turtle--walk-document ctx (treesit-buffer-root-node))
    (rdf-turtle--ctx-store ctx)))

(defun rdf-turtle-parse-string (text &optional store)
  "Like `rdf-turtle-parse-buffer', for TEXT (a string) rather than a buffer."
  (with-temp-buffer
    (insert text)
    (rdf-turtle-parse-buffer store)))

(defun rdf-turtle-parse-file (path &optional store)
  "Like `rdf-turtle-parse-buffer', for the file at PATH."
  (with-temp-buffer
    (insert-file-contents path)
    (rdf-turtle-parse-buffer store)))

;;;###autoload
(defun rdf-turtle-buffer-directive-ctx (&optional base)
  "A `rdf-turtle--ctx' reflecting every BASE/PREFIX declaration in the
current buffer's Turtle text, applied in document order exactly as
`rdf-turtle-parse-buffer' would -- i.e. the BASE/PREFIX table active by
the *end* of the buffer.  For callers that need to resolve a raw IRI/
prefixed-name token the same way `rdf-turtle-parse-buffer' would
resolve that same buffer's own triples, without parsing the whole
buffer into a store (e.g. `shex-validate--data-shapemap-base-iri',
resolving a ShapeMap's relative node references the same way
`read-data' resolved that data buffer's own relative subject/object
IRIs -- mirroring `shexc-shexj-buffer-directive-ctx' for schemas).
BASE seeds the context exactly as `rdf-turtle-parse-buffer''s own
BASE argument does -- pass the same value here as there, or the two
resolve the same buffer's IRIs differently."
  (let ((ctx (rdf-turtle--ctx-create :base base)))
    (treesit-parser-create 'turtle)
    (dolist (statement (rdf-turtle--children-of-types (treesit-buffer-root-node 'turtle) '("statement")))
      (let ((child (treesit-node-child statement 0 t)))
        (when (equal (treesit-node-type child) "directive")
          (rdf-turtle--process-directive ctx child))))
    ctx))

(provide 'rdf-turtle)

;;; rdf-turtle.el ends here
