Add nquads format

Julien LepillerTue Apr 07 04:57:36+0200 2020

e8c0b29

Add nquads format

Makefile.am

1111 
  turtle/fromrdf.scm \
1212 
  turtle/parser.scm \
1313 
  turtle/tordf.scm \
14+
  nquads/parser.scm \
15+
  nquads/tordf.scm \
1416 
  iri/iri.scm \
1517 
  test-modules/testsuite.scm \
1618 
  test-modules/online.scm \
1719 
  test-modules/result.scm \
20+
  tests/nquads.scm \
1821 
  tests/semantics.scm \
1922 
  tests/turtle.scm
2023 
configure.ac
1111 
GUILE_SITE_DIR
1212 
1313 
AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
14+
AC_CONFIG_FILES([tests/nquads.scm], [chmod +x tests/nquads.scm])
1415 
AC_CONFIG_FILES([tests/semantics.scm], [chmod +x tests/semantics.scm])
1516 
AC_CONFIG_FILES([tests/turtle.scm], [chmod +x tests/turtle.scm])
1617 
AC_CONFIG_FILES(Makefile)
nquads/parser.scm unknown status 1
1+
;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
2+
;;;; 
3+
;;;; This library is free software; you can redistribute it and/or
4+
;;;; modify it under the terms of the GNU Lesser General Public
5+
;;;; License as published by the Free Software Foundation; either
6+
;;;; version 3 of the License, or (at your option) any later version.
7+
;;;; 
8+
;;;; This library is distributed in the hope that it will be useful,
9+
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10+
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11+
;;;; Lesser General Public License for more details.
12+
;;;; 
13+
;;;; You should have received a copy of the GNU Lesser General Public
14+
;;;; License along with this library; if not, write to the Free Software
15+
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16+
;;;; 
17+
18+
(define-module (nquads parser)
19+
  #:use-module (ice-9 peg)
20+
  #:export (parse-nquads))
21+
22+
;; Productions for terminals
23+
(define-peg-pattern langtag all
24+
  (and (ignore "@") (+ (or (range #\a #\z) (range #\A #\Z)))
25+
       (* (and "-" (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9)))))))
26+
(define-peg-pattern eol none (+ (or "\n" "\r")))
27+
(define-peg-pattern iriref all
28+
  (and (ignore "<")
29+
       (* (or "!" (range #\x23 #\x3b) "=" (range #\x3f #\x5b) "]" "_"
30+
              (range #\x61 #\x7a) (range #\x7e #\x10ffff) uchar))
31+
       (ignore ">")))
32+
(define-peg-pattern string-literal-quote all
33+
  (and (ignore "\"")
34+
       (* (or (range #\x00 #\x09) (range #\x0b #\x0c) (range #\x0d #\x21)
35+
              (range #\x23 #\x5b) (range #\x5d #\x10ffff) echar uchar))
36+
       (ignore "\"")))
37+
(define-peg-pattern blank-node-label all
38+
  (and "_:" (or pn-chars-u (range #\0 #\9)) (* (and (* ".") pn-chars))))
39+
(define-peg-pattern uchar all
40+
  (or (and (ignore "\\u") hex hex hex hex)
41+
      (and (ignore "\\U") hex hex hex hex hex hex hex hex)))
42+
(define-peg-pattern echar all
43+
  (or "\\t" "\\b" "\\n" "\\r" "\\f" "\\\"" "\\'" "\\\\"))
44+
(define-peg-pattern pn-chars-base body
45+
  (or (range #\A #\Z) (range #\a #\z) (range #\x00c0 #\x00d6)
46+
      (range #\x00d8 #\x00f6) (range #\x00f8 #\x02ff) (range #\x0370 #\x037d)
47+
      (range #\x037f #\x1fff) (range #\x200c #\x200d) (range #\x2070 #\x218f)
48+
      (range #\x2c00 #\x2fef) (range #\x3001 #\xd7ff) (range #\xf900 #\xfdcf)
49+
      (range #\xfdf0 #\xfffd) (range #\x10000 #\xeffff)))
50+
(define-peg-pattern pn-chars-u body (or pn-chars-base "_"))
51+
(define-peg-pattern pn-chars body
52+
  (or pn-chars-u "-" (range #\0 #\9) "??" (range #\x0300 #\x036f)
53+
      (range #\x203f #\x2040)))
54+
(define-peg-pattern hex body (or (range #\0 #\9) (range #\a #\f) (range #\A #\F)))
55+
56+
;; Grammar
57+
(define-peg-pattern unrecognized body (range #\x00 #\x10ffff))
58+
(define-peg-pattern comment body (and "#" (* (or (range #\x00 #\x09)
59+
                                                 (range #\x0B #\x0C)
60+
                                                 (range #\x0E #\x10FFFF)))))
61+
(define-peg-pattern WS none (* (or comment "\t" " ")))
62+
63+
(define-peg-pattern nquads-doc body (and (* (and WS (? eol))) (* statement)))
64+
(define-peg-pattern statement all
65+
  (or
66+
    (and WS subject WS iriref WS object WS (? graph-label) WS (? (ignore "."))
67+
         (* (and WS eol)))
68+
    (* unrecognized)))
69+
(define-peg-pattern subject body
70+
  (or iriref blank-node-label))
71+
(define-peg-pattern object body
72+
  (or iriref blank-node-label literal))
73+
(define-peg-pattern graph-label body
74+
  (or iriref blank-node-label))
75+
(define-peg-pattern literal all
76+
  (and string-literal-quote (? (or (and "^^" iriref) langtag))))
77+
78+
79+
(define (parse-nquads str)
80+
  (peg:tree (match-pattern nquads-doc str)))
nquads/tordf.scm unknown status 1
1+
;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
2+
;;;; 
3+
;;;; This library is free software; you can redistribute it and/or
4+
;;;; modify it under the terms of the GNU Lesser General Public
5+
;;;; License as published by the Free Software Foundation; either
6+
;;;; version 3 of the License, or (at your option) any later version.
7+
;;;; 
8+
;;;; This library is distributed in the hope that it will be useful,
9+
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10+
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11+
;;;; Lesser General Public License for more details.
12+
;;;; 
13+
;;;; You should have received a copy of the GNU Lesser General Public
14+
;;;; License along with this library; if not, write to the Free Software
15+
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16+
;;;; 
17+
18+
(define-module (nquads tordf)
19+
  #:use-module (ice-9 match)
20+
  #:use-module (ice-9 textual-ports)
21+
  #:use-module (iri iri)
22+
  #:use-module (nquads parser)
23+
  #:use-module (srfi srfi-9)
24+
  #:use-module (rdf rdf)
25+
  #:use-module (rdf utils)
26+
  #:use-module (web uri)
27+
  #:export (nquads->rdf))
28+
29+
(define-record-type parser-state
30+
  (make-parser-state bnode-labels blank-node-gen result)
31+
  parser-state?
32+
  (bnode-labels   parser-state-bnode-labels)
33+
  (blank-node-gen parser-state-blank-node-gen)
34+
  (result         parser-state-result))
35+
36+
(define* (update-parser-state
37+
           state #:key (bnode-labels (parser-state-bnode-labels state))
38+
                       (blank-node-gen (parser-state-blank-node-gen state))
39+
                       (result (parser-state-result state)))
40+
  (make-parser-state bnode-labels blank-node-gen result))
41+
42+
(define (create-generate-blank-node)
43+
  (define num 0)
44+
  (lambda ()
45+
    (set! num (+ num 1))
46+
    num))
47+
48+
(define* (parse-string str #:optional for-iri?)
49+
  (match str
50+
    ((? string? str) str)
51+
    ((component str ...)
52+
     (match component
53+
       ((? string? str1)
54+
        (string-append str1 (parse-string str)))
55+
       (('uchar n)
56+
        (string-append (string (integer->char (string->number n 16)))
57+
                       (parse-string str)))
58+
       (('echar e)
59+
        (string-append
60+
          (match e
61+
            ("\\t" "\t")
62+
            ("\\b" "\b")
63+
            ("\\n" "\n")
64+
            ("\\r" "\r")
65+
            ("\\f" "\f")
66+
            ("\\\\" "\\")
67+
            ("\\\"" "\"")
68+
            ("\\'" "'"))
69+
          (parse-string str)))))
70+
    (() "")))
71+
72+
(define (valid-iri? iri)
73+
  (and (not (string-any (ucs-range->char-set 0 33) iri))
74+
       (not (string-any #\< iri))
75+
       (not (string-any #\> iri))
76+
       (string->uri iri)))
77+
78+
(define (parse-iri iri state)
79+
  (match iri
80+
    ('iriref ""
81+
     (throw 'invalid-iri ""))
82+
    (('iriref iri)
83+
     (if (valid-iri? iri) iri (throw 'invalid-iri iri)))
84+
    (('iriref iri ...)
85+
     (let ((iri (parse-string iri)))
86+
       (if (valid-iri? iri) iri (throw 'invalid-iri iri))))))
87+
88+
(define (parse-object object state)
89+
  (pk 'object object)
90+
  (match object
91+
    (('literal ('string-literal-quote ("^^" iri)))
92+
     (let* ((iri (parse-iri iri state))
93+
            (object (make-rdf-literal "" iri #f)))
94+
       (update-parser-state state
95+
         #:result object)))
96+
    (('literal ('string-literal-quote ('langtag lang)))
97+
     (let ((object
98+
           (make-rdf-literal
99+
             ""
100+
             "http://www.w3.org/1999/02/22-rdf-syntax-ns#langString"
101+
             lang)))
102+
       (update-parser-state state
103+
         #:result object)))
104+
    (('literal ('string-literal-quote str ...))
105+
     (let ((object
106+
             (make-rdf-literal (parse-string str)
107+
                               "http://www.w3.org/2001/XMLSchema#string" #f)))
108+
       (update-parser-state state
109+
         #:result object)))
110+
    (('literal ('string-literal-quote str ...) ("^^" iri))
111+
     (let* ((iri (parse-iri iri state))
112+
            (object (make-rdf-literal (parse-string str) iri #f)))
113+
       (update-parser-state state
114+
         #:result object)))
115+
    (('literal ('string-literal-quote str ...) ('langtag lang))
116+
     (let ((object
117+
           (make-rdf-literal
118+
             (parse-string str)
119+
             "http://www.w3.org/1999/02/22-rdf-syntax-ns#langString"
120+
             lang)))
121+
       (update-parser-state state
122+
         #:result object)))
123+
    (('literal)
124+
     (let ((object
125+
           (make-rdf-literal
126+
             ""
127+
             "http://www.w3.org/1999/02/22-rdf-syntax-ns#string"
128+
             #f)))
129+
       (update-parser-state state
130+
         #:result object)))
131+
    (('blank-node-label label)
132+
     (let* ((node
133+
              (or (assoc-ref (parser-state-bnode-labels state) label)
134+
                  ((parser-state-blank-node-gen state))))
135+
            (state
136+
              (if (assoc-ref (parser-state-bnode-labels state) label)
137+
                  state
138+
                  (update-parser-state state
139+
                    #:bnode-labels
140+
                    (cons
141+
                      (cons label node)
142+
                      (parser-state-bnode-labels state))))))
143+
       (update-parser-state state
144+
         #:bnode-labels
145+
         (if (assoc-ref (parser-state-bnode-labels state) label)
146+
             (parser-state-bnode-labels state)
147+
             (cons (cons label node)
148+
                   (parser-state-bnode-labels state)))
149+
         #:result node)))
150+
    (('iriref _ ...)
151+
     (update-parser-state state
152+
       #:result (parse-iri object state)))))
153+
154+
(define (parse-statement statement state)
155+
  (match statement
156+
    ((subject predicate object)
157+
     (let* ((state (parse-object subject state))
158+
            (subject (parser-state-result state))
159+
            (state (parse-object predicate state))
160+
            (predicate (parser-state-result state))
161+
            (state (parse-object object state))
162+
            (object (parser-state-result state)))
163+
       (update-parser-state state
164+
         #:result (cons "@default" (make-rdf-triple subject predicate object)))))
165+
    ((subject predicate object graph-name)
166+
     (let* ((state (parse-object subject state))
167+
            (subject (parser-state-result state))
168+
            (state (parse-object predicate state))
169+
            (predicate (parser-state-result state))
170+
            (state (parse-object object state))
171+
            (object (parser-state-result state))
172+
            (state (parse-object graph-name state))
173+
            (graph-name (parser-state-result state)))
174+
       (update-parser-state state
175+
         #:result (cons graph-name (make-rdf-triple subject predicate object)))))))
176+
177+
(define (parse-nquads-doc parse-tree state)
178+
  (let loop ((parse-tree parse-tree) (state state) (default-graph '())
179+
                                     (named-graphs '()))
180+
    (pk parse-tree)
181+
    (match parse-tree
182+
      ('() (make-rdf-dataset default-graph named-graphs))
183+
      ((('statement statement ...) parse-tree ...)
184+
       (let* ((state (parse-statement statement state))
185+
              (res (parser-state-result state))
186+
              (graph-name (car res))
187+
              (triple (cdr res)))
188+
         (if (equal? graph-name "@default")
189+
             (loop
190+
               parse-tree
191+
               state
192+
               (cons triple default-graph)
193+
               named-graphs)
194+
             (loop
195+
               parse-tree
196+
               state
197+
               default-graph
198+
               (alist-set
199+
                 named-graphs graph-name
200+
                 (cons triple (assoc-ref named-graphs graph-name)))))))
201+
      (('statement _ ...)
202+
       (loop (list parse-tree) state default-graph named-graphs))
203+
      (((parse-tree ...))
204+
       (loop parse-tree state default-graph named-graphs)))))
205+
206+
(define (nquads->rdf str-or-file)
207+
  (define str
208+
    (cond
209+
      ((file-exists? str-or-file) (call-with-input-file str-or-file get-string-all))
210+
      ((string? str-or-file) str-or-file)))
211+
      
212+
  (let ((parse-tree (parse-nquads str)))
213+
    (parse-nquads-doc
214+
      parse-tree (make-parser-state '() (create-generate-blank-node) #f))))
test-modules/online.scm
2626 
  #:use-module (rdf rdf)
2727 
  #:use-module ((rdf xsd) #:prefix xsd:)
2828 
  #:use-module (srfi srfi-1)
29+
  #:use-module (nquads tordf)
2930 
  #:use-module (turtle tordf)
3031 
  #:use-module (web client)
3132 
  #:use-module (web response)
…
8586 
         (type (car (get-objects predicates "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")))
8687 
         (type (car (reverse (string-split type #\#))))
8788 
         (action (car (get-objects predicates "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#action"))))
88-
    (turtle->rdf (get-test-doc action) action)))
89+
    (cond
90+
      ((member type '("TestTurtlePositiveSyntax" "TestTurtleNegativeSyntax"
91+
                      "TestTurtleEval" "PositiveEntailmentTest"
92+
                      "NegativeEntailmentTest"))
93+
       (turtle->rdf (get-test-doc action) action))
94+
      ((member type '("TestNQuadsNegativeSyntax" "TestNQuadsPositiveSyntax"))
95+
       (nquads->rdf (get-test-doc action))))))
8996 
9097 
(define (run-test test)
9198 
  (let* ((predicates (test-case-document test))
test-modules/testsuite.scm
1818 
(define-module (test-modules testsuite)
1919 
  #:export (expected-failures
2020 
            turtle-test-manifest
21+
            nquads-test-manifest
2122 
            semantics-test-manifest))
2223 
2324 
(define expected-failures
2425 
  '())
2526 
2627 
(define turtle-test-manifest "http://www.w3.org/2013/TurtleTests/manifest.ttl")
28+
(define nquads-test-manifest "http://www.w3.org/2013/N-QuadsTests/manifest.ttl")
2729 
(define semantics-test-manifest
2830 
  "https://www.w3.org/2013/rdf-mt-tests/manifest.ttl")
tests/nquads.scm.in unknown status 1
1+
#!@abs_top_srcdir@/pre-inst-env guile
2+
!#
3+
;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
4+
;;;; 
5+
;;;; This library is free software; you can redistribute it and/or
6+
;;;; modify it under the terms of the GNU Lesser General Public
7+
;;;; License as published by the Free Software Foundation; either
8+
;;;; version 3 of the License, or (at your option) any later version.
9+
;;;; 
10+
;;;; This library is distributed in the hope that it will be useful,
11+
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12+
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13+
;;;; Lesser General Public License for more details.
14+
;;;; 
15+
;;;; You should have received a copy of the GNU Lesser General Public
16+
;;;; License along with this library; if not, write to the Free Software
17+
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18+
;;;; 
19+
20+
(use-modules (test-modules online))
21+
(use-modules (test-modules result))
22+
(use-modules (test-modules testsuite))
23+
24+
(run-test-suite nquads-test-manifest expected-failures tap-driver)