turtle/parser.scm \

  turtle/tordf.scm \

;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; This library is free software; you can redistribute it and/or

;;;; modify it under the terms of the GNU Lesser General Public

;;;; License as published by the Free Software Foundation; either

;;;; version 3 of the License, or (at your option) any later version.

;;;; 

;;;; This library 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

;;;; Lesser General Public License for more details.

;;;; 

;;;; You should have received a copy of the GNU Lesser General Public

;;;; License along with this library; if not, write to the Free Software

;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; 

(define-module (turtle parser)

  #:use-module (ice-9 peg)

  #:export (parse-turtle))

;; Productions for terminals

;; [18] 	IRIREF 	::= 	'<' ([^#x00-#x20<>"{}|^`\] | UCHAR)* '>' /* #x00=NULL #01-#x1F=control codes #x20=space */

(define-peg-pattern iriref all

  (and (ignore "<")

       (* (or "!" (range #\x23 #\x3b) "=" (range #\x3f #\x5b) "]" "_"

              (range #\x61 #\x7a) (range #\x7e #\x10ffff) uchar))

       (ignore ">")))

;; [139s] 	PNAME_NS 	::= 	PN_PREFIX? ':'

(define-peg-pattern pname-ns all (and (? pn-prefix) (ignore ":")))

;; [140s] 	PNAME_LN 	::= 	PNAME_NS PN_LOCAL

(define-peg-pattern pname-ln all (and pname-ns pn-local))

;; [141s] 	BLANK_NODE_LABEL 	::= 	'_:' (PN_CHARS_U | [0-9]) ((PN_CHARS | '.')* PN_CHARS)?

(define-peg-pattern blank-node-label all

  (and "_:" (or pn-chars-u (range #\0 #\9)) (* (or pn-chars (and "." pn-chars)))))

;; [144s] 	LANGTAG 	::= 	'@' [a-zA-Z]+ ('-' [a-zA-Z0-9]+)*

(define-peg-pattern langtag all

  (and "@" (+ (or (range #\a #\z) (range #\A #\Z)))

       (* (and "-" (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9))))))

;; [19] 	INTEGER 	::= 	[+-]? [0-9]+

(define-peg-pattern integer all (and (? (or "+" "-")) (+ (range #\0 #\9))))

;; [20] 	DECIMAL 	::= 	[+-]? [0-9]* '.' [0-9]+

(define-peg-pattern decimal all

  (and (? (or "+" "-")) (* (range #\0 #\9)) "." (+ (range #\0 #\9))))

;; [21] 	DOUBLE 	::= 	[+-]? ([0-9]+ '.' [0-9]* EXPONENT | '.' [0-9]+ EXPONENT | [0-9]+ EXPONENT)

(define-peg-pattern double all

  (and (? (or "+" "-"))

       (or (and (+ (range #\0 #\9)) "." (* (range #\0 #\9)) exponent)

           (and "." (+ (range #\0 #\9)) exponent)

           (and (+ (range #\0 #\9)) exponent))))

;; [154s] 	EXPONENT 	::= 	[eE] [+-]? [0-9]+

(define-peg-pattern exponent body

  (and (or "e" "E") (? (or "+" "-")) (+ (range #\0 #\9))))

;; [22] 	STRING_LITERAL_QUOTE 	::= 	'"' ([^#x22#x5C#xA#xD] | ECHAR | UCHAR)* '"' /* #x22=" #x5C=\ #xA=new line #xD=carriage return */

(define-peg-pattern string-literal-quote all

  (and (ignore "\"")

       (* (or (range #\x00 #\x09) (range #\x0b #\x0c) (range #\x0d #\x21)

              (range #\x23 #\x5b) (range #\x5d #\x10ffff) echar uchar))

       (ignore "\"")))

;; [23] 	STRING_LITERAL_SINGLE_QUOTE 	::= 	"'" ([^#x27#x5C#xA#xD] | ECHAR | UCHAR)* "'" /* #x27=' #x5C=\ #xA=new line #xD=carriage return */

(define-peg-pattern string-literal-single-quote all

  (and (ignore "'")

       (* (or (range #\x00 #\x09) (range #\x0b #\x0c) (range #\x0d #\x26)

              (range #\x28 #\x5b) (range #\x5d #\x10ffff) echar uchar))

       (ignore "'")))

;; [24] 	STRING_LITERAL_LONG_SINGLE_QUOTE 	::= 	"'''" (("'" | "''")? ([^'\] | ECHAR | UCHAR))* "'''"

(define-peg-pattern string-literal-long-single-quote all

  (and (ignore "'''")

       (* (and (? (or "''" "'"))

               (or (range #\x00 #\x26) (range #\x28 #\x5b)

                   (range #\x5d #\x10ffff) echar uchar)))

       (ignore "'''")))

;; [25] 	STRING_LITERAL_LONG_QUOTE 	::= 	'"""' (('"' | '""')? ([^"\] | ECHAR | UCHAR))* '"""'

(define-peg-pattern string-literal-long-quote all

  (and (ignore "\"\"\"")

       (* (and (? (or "\"\"" "\""))

               (or (range #\x00 #\x21) (range #\x23 #\x5b)

                   (range #\x5d #\x10ffff) echar uchar)))

       (ignore "\"\"\"")))

;; [26] 	UCHAR 	::= 	'\u' HEX HEX HEX HEX | '\U' HEX HEX HEX HEX HEX HEX HEX HEX

(define-peg-pattern uchar body

  (or (and "\\u" hex hex hex hex)

      (and "\\U" hex hex hex hex hex hex hex hex)))

;; [159s] 	ECHAR 	::= 	'\' [tbnrf"'\]

(define-peg-pattern echar body

  (or "\\t" "\\b" "\\n" "\\r" "\\f" "\\\"" "\\'" "\\\\"))

;; [161s] 	WS 	::= 	#x20 | #x9 | #xD | #xA /* #x20=space #x9=character tabulation #xD=carriage return #xA=new line */

(define-peg-pattern ws body (or " " "\t" "\r" "\n"))

;; [162s] 	ANON 	::= 	'[' WS* ']'

(define-peg-pattern anon all (and "[" (* ws) "]"))

;; [163s] 	PN_CHARS_BASE 	::= 	[A-Z] | [a-z] | [#x00C0-#x00D6] | [#x00D8-#x00F6] | [#x00F8-#x02FF] | [#x0370-#x037D] | [#x037F-#x1FFF] | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF]

(define-peg-pattern pn-chars-base body

  (or (range #\A #\Z) (range #\a #\z) (range #\x00c0 #\x00d6)

      (range #\x00d8 #\x00f6) (range #\x00f8 #\x02ff) (range #\x0370 #\x037d)

      (range #\x037f #\x1fff) (range #\x200c #\x200d) (range #\x2070 #\x218f)

      (range #\x2c00 #\x2fef) (range #\x3001 #\xd7ff) (range #\xf900 #\xfdcf)

      (range #\xfdf0 #\xfffd) (range #\x10000 #\xeffff)))

;; [164s] 	PN_CHARS_U 	::= 	PN_CHARS_BASE | '_'

(define-peg-pattern pn-chars-u body (or pn-chars-base "_"))

;; [166s] 	PN_CHARS 	::= 	PN_CHARS_U | '-' | [0-9] | #x00B7 | [#x0300-#x036F] | [#x203F-#x2040]

(define-peg-pattern pn-chars body

  (or pn-chars-u "-" (range #\0 #\9) "??" (range #\x0300 #\x036f)

      (range #\x203f #\x2040)))

;; [167s] 	PN_PREFIX 	::= 	PN_CHARS_BASE ((PN_CHARS | '.')* PN_CHARS)?

(define-peg-pattern pn-prefix body

  (and pn-chars-base (* (or pn-chars (and "." pn-chars)))))

;; [168s] 	PN_LOCAL 	::= 	(PN_CHARS_U | ':' | [0-9] | PLX) ((PN_CHARS | '.' | ':' | PLX)* (PN_CHARS | ':' | PLX))?

(define-peg-pattern pn-local body

  (and (or pn-chars-u ":" (range #\0 #\9) plx)

       (* (or pn-chars ":" "plx" (and "." (or pn-chars ":" plx))))))

;; [169s] 	PLX 	::= 	PERCENT | PN_LOCAL_ESC

(define-peg-pattern plx body (or percent pn-local-esc))

;; [170s] 	PERCENT 	::= 	'%' HEX HEX

(define-peg-pattern percent body (and "%" hex hex))

;; [171s] 	HEX 	::= 	[0-9] | [A-F] | [a-f]

(define-peg-pattern hex body (or (range #\0 #\9) (range #\a #\f) (range #\A #\F)))

;; [172s] 	PN_LOCAL_ESC 	::= 	'\' ('_' | '~' | '.' | '-' | '!' | '$' | '&' | "'" | '(' | ')' | '*' | '+' | ',' | ';' | '=' | '/' | '?' | '#' | '@' | '%')

(define-peg-pattern pn-local-esc body

  (and "\\" (or "~" "." "-" "!" "$" "&" "'" "(" ")" "*" "+" "," ";" "=" "/"

                "?" "#" "@" "%" "_")))

(define-peg-pattern comment body (and "#" (* (or (range #\x00 #\x09)

                                                 (range #\x0B #\x0C)

                                                 (range #\x0E #\x10FFFF)))))

(define-peg-pattern WS none (* (or comment ws)))

(define-peg-pattern unrecognized body (range #\x00 #\x10ffff))

;; [1] 	turtleDoc 	::= 	statement*

(define-peg-pattern turtle-doc body (and WS (* (and statement WS))))

;; [2] 	statement 	::= 	directive | triples '.'

(define-peg-pattern statement body

  (or directive (and triples WS (ignore ".")) (* unrecognized)))

;; [3] 	directive 	::= 	prefixID | base | sparqlPrefix | sparqlBase

(define-peg-pattern directive body (or prefix-id base sparql-prefix sparql-base))

;; [4] 	prefixID 	::= 	'@prefix' PNAME_NS IRIREF '.'

(define-peg-pattern prefix-id all

  (and (ignore "@prefix") WS pname-ns WS iriref WS (ignore ".")))

;; [5] 	base 	::= 	'@base' IRIREF '.'

(define-peg-pattern base all

  (and (ignore "@base") WS iriref WS (ignore ".")))

;; [5s] 	sparqlBase 	::= 	"BASE" IRIREF

(define-peg-pattern sparql-base all

  (and (ignore (and (or "b" "B") (or "a" "A") (or "s" "S") (or "e" "E")))

       WS iriref))

;; [6s] 	sparqlPrefix 	::= 	"PREFIX" PNAME_NS IRIREF

(define-peg-pattern sparql-prefix all

      (and (ignore (and (or "p" "P") (or "r" "R") (or "e" "E") (or "f" "F")

                        (or "i" "I") (or "x" "X")))

           WS pname-ns WS iriref))

;; [6] 	triples 	::= 	subject predicateObjectList | blankNodePropertyList predicateObjectList?

(define-peg-pattern triples all

  (or (and subject WS predicate-object-list)

      (and blank-node-property-list WS (? predicate-object-list))))

;; [7] 	predicateObjectList 	::= 	verb objectList (';' (verb objectList)?)*

(define-peg-pattern predicate-object-list all

  (and verb WS object-list

       (* (and WS (ignore ";") WS (? (and verb WS object-list))))))

;; [8] 	objectList 	::= 	object (',' object)*

(define-peg-pattern object-list all

  (and object (* (and WS (ignore ",") WS object))))

;; [9] 	verb 	::= 	predicate | 'a'

(define-peg-pattern verb all (or predicate "a"))

;; [10] 	subject 	::= 	iri | BlankNode | collection

(define-peg-pattern subject all (or iri blank-node collection))

;; [11] 	predicate 	::= 	iri

(define-peg-pattern predicate all iri)

;; [12] 	object 	::= 	iri | BlankNode | collection | blankNodePropertyList | literal

(define-peg-pattern object all

  (or iri blank-node collection blank-node-property-list literal))

;; [13] 	literal 	::= 	RDFLiteral | NumericLiteral | BooleanLiteral

(define-peg-pattern literal body

  (or rdf-literal numeric-literal boolean-literal))

;; [14] 	blankNodePropertyList 	::= 	'[' predicateObjectList ']'

(define-peg-pattern blank-node-property-list all

  (and (ignore "[") WS predicate-object-list WS (ignore "]")))

;; [15] 	collection 	::= 	'(' object* ')'

(define-peg-pattern collection all

  (and (ignore "(") WS (* (and object WS)) (ignore ")")))

;; [16] 	NumericLiteral 	::= 	INTEGER | DECIMAL | DOUBLE

(define-peg-pattern numeric-literal all (or integer decimal double))

;; [128s] 	RDFLiteral 	::= 	String (LANGTAG | '^^' iri)?

(define-peg-pattern rdf-literal all

  (and string-pat WS (? (or langtag (and "^^" WS iri)))))

;; [133s] 	BooleanLiteral 	::= 	'true' | 'false'

(define-peg-pattern boolean-literal all (or "true" "false"))

;; [17] 	String 	::= 	STRING_LITERAL_QUOTE | STRING_LITERAL_SINGLE_QUOTE | STRING_LITERAL_LONG_SINGLE_QUOTE | STRING_LITERAL_LONG_QUOTE

(define-peg-pattern string-pat all

  (or string-literal-long-single-quote string-literal-long-quote

      string-literal-quote string-literal-single-quote))

;; [135s] 	iri 	::= 	IRIREF | PrefixedName

(define-peg-pattern iri all (or iriref prefixed-name))

;; [136s] 	PrefixedName 	::= 	PNAME_LN | PNAME_NS

(define-peg-pattern prefixed-name all (or pname-ln pname-ns))

;; [137s] 	BlankNode 	::= 	BLANK_NODE_LABEL | ANON

(define-peg-pattern blank-node all (or blank-node-label anon))

(define (parse-turtle str)

  (peg:tree (match-pattern turtle-doc str)))

;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; This library is free software; you can redistribute it and/or

;;;; modify it under the terms of the GNU Lesser General Public

;;;; License as published by the Free Software Foundation; either

;;;; version 3 of the License, or (at your option) any later version.

;;;; 

;;;; This library 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

;;;; Lesser General Public License for more details.

;;;; 

;;;; You should have received a copy of the GNU Lesser General Public

;;;; License along with this library; if not, write to the Free Software

;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; 

(define-module (turtle tordf)

  #:use-module (ice-9 match)

  #:use-module (ice-9 textual-ports)

  #:use-module (iri iri)

  #:use-module (turtle parser)

  #:use-module (srfi srfi-9)

  #:use-module (rdf rdf)

  #:use-module ((rdf xsd) #:prefix xsd:)

  #:export (turtle->rdf))

(define-record-type parser-state

  (make-parser-state base-uri namespaces bnode-labels cur-subject cur-predicate

                     blank-node-gen result)

  parser-state?

  (base-uri       parser-state-base-uri)

  (namespaces     parser-state-namespaces)

  (bnode-labels   parser-state-bnode-labels)

  (cur-subject    parser-state-cur-subject)

  (cur-predicate  parser-state-cur-predicate)

  (blank-node-gen parser-state-blank-node-gen)

  (result         parser-state-result))

(define* (update-parser-state

           state #:key (base-uri (parser-state-base-uri state))

                       (namespaces (parser-state-namespaces state))

                       (bnode-labels (parser-state-bnode-labels state))

                       (cur-subject (parser-state-cur-subject state))

                       (cur-predicate (parser-state-cur-predicate state))

                       (blank-node-gen (parser-state-blank-node-gen state))

                       (result (parser-state-result state)))

  (make-parser-state base-uri namespaces bnode-labels cur-subject cur-predicate

                     blank-node-gen result))

(define (create-generate-blank-node)

  (define num 0)

  (lambda ()

    (set! num (+ num 1))

    num))

(define (add-ns-to-state state ns iri)

  (pk 'iri iri)

  (update-parser-state state

    #:namespaces (cons (cons ns iri) (parser-state-namespaces state))))

(define (parse-iri iri state)

  (format #t "iri: ~a~%" iri)

  (match iri

    (('iri ('prefixed-name ('pname-ln ('pname-ns ns) suffix)))

     `(("iri" . ,(string-append (assoc-ref (parser-state-namespaces state) ns)

                               suffix))

       ("state" . ,state)))

    (('iri ('prefixed-name ('pname-ln ('pname-ns suffix))))

     `(("iri" . ,(string-append (assoc-ref (parser-state-namespaces state) "")

                               suffix))

       ("state" . ,state)))

    (('iri 'iriref)

     `(("iri" . ,(resolve-iri (parser-state-base-uri state) ""))

       ("state" . ,state)))

    (('iri ('iriref iri))

     `(("iri" . ,(resolve-iri (parser-state-base-uri state) iri))

       ("state" . ,state)))

    (('blank-node ('blank-node-label label))

     (if (assoc-ref (parser-state-bnode-labels state) label)

         `(("iri" . ,(assoc-ref (parser-state-bnode-labels state) label))

           ("state" . ,state))

         (let ((node ((parser-state-blank-node-gen state))))

           `(("iri" . ,node)

             ("state" . ,(update-parser-state state

                           #:bnode-labels

                           (cons

                             (cons label node)

                             (parser-state-bnode-labels state))))))))))

(define (parse-verb verb state)

  (match verb

    ("a" `(("verb" . "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")

           ("state" . ,state)))

    (('predicate iri)

     (let ((res (parse-iri iri state)))

       `(("verb" . ,(assoc-ref res "iri"))

         ("state" . ,(assoc-ref res "state")))))))

(define (parse-object object state)

  (pk 'object object)

  (match object

    (('rdf-literal ('string-pat ('string-literal-quote str)))

     (update-parser-state state

       #:result

       (cons

         (make-rdf-triple

           (parser-state-cur-subject state)

           (parser-state-cur-predicate state)

           (make-rdf-literal str xsd:string #f))

         (parser-state-result state))))

    (('blank-node-property-list ('predicate-object-list po ...))

     (let* ((node ((parser-state-blank-node-gen state)))

            (new-state (parse-predicate-object

                         po (update-parser-state state #:cur-subject node))))

       (update-parser-state new-state

         #:cur-subject (parser-state-cur-subject state)

         #:cur-predicate (parser-state-cur-predicate state)

         #:result

         (cons

           (make-rdf-triple

             (parser-state-cur-subject state)

             (parser-state-cur-predicate state)

             node)

           (parser-state-result new-state)))))

    (('collection objects ...)

     (let loop ((objects objects) (state state))

       (match objects

         ('() state)

         ((('object object) objects ...)

          (loop objects (parse-object object state))))))

    (('iri _)

     (let* ((res (parse-iri object state))

            (iri (assoc-ref res "iri"))

            (state (assoc-ref res "state")))

       (update-parser-state state

         #:result

         (cons

           (make-rdf-triple

             (parser-state-cur-subject state)

             (parser-state-cur-predicate state)

             iri)

           (parser-state-result state)))))))

(define (parse-object-list ol state)

  (let loop ((ol ol) (state state))

    (pk 'ol ol)

    (match ol

      ('() state)

      ((('object object) ol ...)

       (loop ol (parse-object object state)))

      ((ol)

       (loop ol state)))))

(define (parse-predicate-object po state)

  (let loop ((po po) (state state))

    (pk 'po po)

    (match po

      ((('verb verb) ('object-list ol ...) po)

       (let* ((verb (parse-verb verb state))

              (state (assoc-ref verb "state"))

              (verb (assoc-ref verb "verb"))

              (new-state (update-parser-state state #:cur-predicate verb))

              (res (parse-object-list ol new-state)))

         (loop po res)))

      ((('verb verb) ('object-list ol ...))

       (let* ((verb (parse-verb verb state))

              (state (assoc-ref verb "state"))

              (verb (assoc-ref verb "verb"))

              (new-state (update-parser-state state #:cur-predicate verb))

              (res (parse-object-list ol new-state)))

         res))

      (((('verb verb) ('object-list ol ...)) po ...)

       (let* ((verb (parse-verb verb state))

              (state (assoc-ref verb "state"))

              (verb (assoc-ref verb "verb"))

              (new-state (update-parser-state state #:cur-predicate verb))

              (res (parse-object-list ol new-state)))

         (loop po res)))

      ('() state)

      ((po)

       (loop po state)))))

(define (parse-triples t state)

  (match t

    ((('subject iri) ('predicate-object-list predicate-object ...))

     (let* ((res (parse-iri iri state))

            (iri (assoc-ref res "iri"))

            (state (assoc-ref res "state"))

            (state (update-parser-state state

                    #:cur-subject iri)))

       (parse-predicate-object predicate-object state)))))

(define (parse-turtle-doc parse-tree state)

  (let loop ((parse-tree parse-tree) (state state))

    (match parse-tree

      ('() (parser-state-result state))

      ((('prefix-id ('pname-ns ns) ('iriref iri)) parse-tree ...)

       (loop parse-tree

             (add-ns-to-state

               state ns (resolve-iri (parser-state-base-uri state) iri))))

      ((('prefix-id ('pname-ns ('iriref iri))) parse-tree ...)

       (loop parse-tree

             (add-ns-to-state

               state "" (resolve-iri (parser-state-base-uri state) iri))))

      ((('sparql-prefix ('pname-ns ns) ('iriref iri)) parse-tree ...)

       (loop parse-tree

             (add-ns-to-state

               state ns (resolve-iri (parser-state-base-uri state) iri))))

      ((('sparql-prefix ('pname-ns ('iriref iri))) parse-tree ...)

       (loop parse-tree

             (add-ns-to-state

               state "" (resolve-iri (parser-state-base-uri state) iri))))

      ((('base ('iriref iri)) parse-tree ...)

       (loop parse-tree

             (update-parser-state

               state #:base-uri (resolve-iri (parser-state-base-uri state) iri))))

      ((('sparql-base ('iriref iri)) parse-tree ...)

       (loop parse-tree

             (update-parser-state

               state #:base-uri (resolve-iri iri (parser-state-base-uri state)))))

      ((('triples t ...) parse-tree ...)

       (format #t "triples: ~a~%" t)

       (let ((res (parse-triples t state)))

         (loop parse-tree (parse-triples t state))))

      ;; otherwise, it's a single element, not a list of statements

      (((? symbol? _) _ ...) (loop (list parse-tree) state)))))

(define (tordf parse-tree base)

  (define state

    (make-parser-state base '() '() #f #f (create-generate-blank-node) '()))

  (parse-turtle-doc parse-tree state))

(define (turtle->rdf str-or-file base)

  (define str

    (cond

      ((file-exists? str-or-file) (call-with-input-file str-or-file get-string-all))

      ((string? str-or-file) str-or-file)))

  (let ((parse-tree (parse-turtle str)))

    (tordf parse-tree base)))