[isidorus-cvs] r340 - in trunk/src: . TM-SPARQL base-tools model xml/rdf xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Nov 17 21:41:59 UTC 2010
Author: lgiessmann
Date: Wed Nov 17 16:41:59 2010
New Revision: 340
Log:
added a SPARQL-Query class with several accessor-methods. This class contains the actual query-string, some query-attributes and the result objects; started to implement a SPARQL-parser => currently the PREFIX parts can be processed; added some functions to base-tools
Added:
trunk/src/TM-SPARQL/sparql_parser.lisp
- copied, changed from r336, /trunk/src/TM-SPARQL/sparql_tokenizer.lisp
Removed:
trunk/src/TM-SPARQL/sparql_tokenizer.lisp
Modified:
trunk/src/TM-SPARQL/sparql.lisp
trunk/src/base-tools/base-tools.lisp
trunk/src/isidorus.asd
trunk/src/model/datamodel.lisp
trunk/src/model/exceptions.lisp
trunk/src/xml/rdf/exporter.lisp
trunk/src/xml/xtm/tools.lisp
Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp (original)
+++ trunk/src/TM-SPARQL/sparql.lisp Wed Nov 17 16:41:59 2010
@@ -7,4 +7,60 @@
;;+ trunk/docs/LGPL-LICENSE.txt.
;;+-----------------------------------------------------------------------------
+(defpackage :TM-SPARQL
+ (:use :cl :datamodel :base-tools :exceptions)
+ (:export :SPARQL-Query))
+
+
(in-package :TM-SPARQL)
+
+(defvar *empty-label* "_empty_label_symbol")
+
+
+(defclass SPARQL-Query ()
+ ((original-query :initarg :original-query
+ :reader original-query
+ :type String
+ :initform (error
+ (make-condition
+ 'missing-query-string-error
+ :message "From TM-Query(): original-query must be set"))
+ :documentation "Containst the original received querry as string")
+ (prefix-list :initarg :prefix-list
+ :reader prefix-list
+ :type List
+ :documentation "A list of the form
+ ((:label 'id' :value 'prefix'))")
+ (variables :initarg :variables
+ :accessor :variables
+ :type List
+ :documentation "A list of the form ((:variable var-symbol
+ :value value-object)), that contains tuples
+ for each variable and its result.")
+ (select-statements :initarg :select-statements
+ :accessor select-statements
+ :type List
+ :documentation "A list of the form ((:statement 'statement'
+ :value value-object))")))
+
+
+(defgeneric add-prefix (construct prefix-label prefix-value)
+ (:documentation "Adds the new prefix tuple to the list of all existing.
+ If there already exists a tuple with the same label
+ the label's value will be overwritten by the new value.")
+ (:method ((construct SPARQL-Query) (prefix-label Symbol) (prefix-value String))
+ (let ((existing-tuple
+ (find-if #'(lambda(x)
+ (eql (getf x :label) prefix-label))
+ (prefix-list construct))))
+ (if existing-tuple
+ (setf (getf existing-tuple :value) prefix-value)
+ (push (list :label prefix-label :value prefix-value)
+ (slot-value construct 'prefix-list))))))
+
+
+
+(defmethod initialize-instance :after ((construct SPARQL-Query) &rest args)
+ (declare (ignorable args))
+ (parser-start construct)
+ construct)
Copied: trunk/src/TM-SPARQL/sparql_parser.lisp (from r336, /trunk/src/TM-SPARQL/sparql_tokenizer.lisp)
==============================================================================
--- /trunk/src/TM-SPARQL/sparql_tokenizer.lisp (original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp Wed Nov 17 16:41:59 2010
@@ -7,8 +7,113 @@
;;+ trunk/docs/LGPL-LICENSE.txt.
;;+-----------------------------------------------------------------------------
-(defpackage :TM-SPARQL
- (:use :cl :datamodel))
+(in-package :TM-SPARQL)
+(defun make-sparql-parser-condition(rest-of-query entire-query expected)
+ "Creates a spqrql-parser-error object."
+ (declare (String rest-of-query entire-query expected))
+ (let ((message
+ (format nil "The query:~%~a bad token on position ~a. Expected: ~a"
+ entire-query (- (length entire-query)
+ (length rest-of-query))
+ expected)))
+ (make-condition 'sparql-parser-error :message message)))
-(in-package :TM-SPARQL)
+
+
+(defgeneric parser-start(construct query-string)
+ (:documentation "The entry point of the SPARQL-parser.")
+ (:method ((construct SPARQL-Query) (query-string String))
+ (let ((trimmed-query-string (trim-whitespace-left query-string)))
+ (cond ((string-starts-with trimmed-query-string "SELECT")
+ (parse-prefixes construct
+ (string-after trimmed-query-string "SELECT")))
+ ((string-starts-with trimmed-query-string "PREFIX")
+ nil) ;TODO: implement
+ ((string-starts-with trimmed-query-string "BASE")
+ nil) ;TODO: implement
+ (t
+ (error (make-sparql-parser-condition
+ trimmed-query-string (original-query construct)
+ "SELECT, PREFIX or BASE")))))))
+
+
+(defgeneric parse-prefixes (construct query-string)
+ (:documentation "Sets the correponding prefix-tuples in the passed object.")
+ (:method ((construct SPARQL-Query) (query-string String))
+ (let ((trimmed-string (trim-whitespace-left query-string)))
+ (if (string-starts-with trimmed-string ":")
+ (let ((results
+ (parse-bracket-value (subseq trimmed-string 1) construct)))
+ (add-prefix construct *empty-label* (getf results :value))
+ (parser-start construct (getf results :query-string)))
+ (let* ((label-name
+ (trim-whitespace-right (string-until trimmed-string ":")))
+ (next-query-str
+ (trim-whitespace-left (string-after trimmed-string ":")))
+ (results (parse-bracket-value next-query-str construct)))
+ (add-prefix construct label-name (getf results :value))
+ (parser-start construct (getf results :query-string)))))))
+
+
+(defun parse-bracket-value(query-string query-object &key (open "<") (close ">"))
+ "A helper function that checks the value of a statement within
+ two brackets, i.e. <prefix-value>. A list of the
+ form (:query-string string :value string) is returned."
+ (declare (String query-string open close)
+ (SPARQL-Query query-object))
+ (let ((trimmed-string (trim-whitespace-left query-string)))
+ (if (and (string-starts-with trimmed-string open)
+ (> (length (string-after trimmed-string close)) 0))
+ (let* ((pref-url
+ (string-until (string-after trimmed-string open) close))
+ (next-query-str
+ (string-after pref-url close)))
+ (unless next-query-str
+ (error (make-sparql-parser-condition
+ trimmed-string (original-query query-object)
+ close)))
+ (list :query-string next-query-str
+ :value pref-url))
+ (error (make-sparql-parser-condition
+ trimmed-string (original-query query-object)
+ open)))))
+
+
+
+;((PREFIX bounding: <uri-prefix>)|(PREFIX : <uri-prefix>)*
+;(BASE <base-uri>)*)*
+;SELECT ?varName+
+;WHERE {
+;(({?subjectOrVarName predicateOrVarName objectOrVarName}?)*
+;({?FILTER (filterExpression)}?)*
+;(BASE <base-uri>)*)*
+;}
+;Grouping
+;{}
+;Base
+;BASE <uri>
+;…
+;<book>
+;-> uri/book
+;Literals
+;(“anyCharacter*“)|(‘anyCharacter*‘)((anyUri)|(@languageTag)){0,1}
+;
+;Variables
+;($anyChar*)|(?anyChar*)
+;?var = $var
+;Predicate object-lists
+;?x foaf:name ?name ;
+;foaf:mbox ?mbox .
+;This is the same as writing the triple patterns:
+;?x foaf:name ?name .
+;?x foaf:mbox ?mbox .
+;rdf:type
+;rdf:type = a
+;Empty Graph Pattern
+;The group pattern:
+;{ }
+;matches any graph (including the empty graph) with one solution that does not bind any variables. For example:
+;SELECT ?x
+;WHERE {}
+;matches with one solution in which variable x is not bound."
\ No newline at end of file
Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp (original)
+++ trunk/src/base-tools/base-tools.lisp Wed Nov 17 16:41:59 2010
@@ -13,7 +13,14 @@
(:export :push-string
:when-do
:remove-null
- :full-path))
+ :full-path
+ :trim-whitespace-left
+ :trim-whitespace-right
+ :trim-whitespace
+ :string-starts-with
+ :string-starts-with-char
+ :string-until
+ :string-after))
(in-package :base-tools)
@@ -52,4 +59,53 @@
(full-path-string ""))
(dolist (segment segments)
(push-string segment full-path-string))
- (concatenate 'string full-path-string "/" (pathname-name pathname))))
\ No newline at end of file
+ (concatenate 'string full-path-string "/" (pathname-name pathname))))
+
+
+(defun trim-whitespace-left (value)
+ "Uses string-left-trim with a predefined character-list."
+ (declare (String value))
+ (string-left-trim '(#\Space #\Tab #\Newline) value))
+
+
+(defun trim-whitespace-right (value)
+ "Uses string-right-trim with a predefined character-list."
+ (declare (String value))
+ (string-right-trim '(#\Space #\Tab #\Newline) value))
+
+
+(defun trim-whitespace (value)
+ "Uses string-trim with a predefined character-list."
+ (declare (String value))
+ (string-trim '(#\Space #\Tab #\Newline) value))
+
+
+(defun string-starts-with (str prefix)
+ "Checks if string str starts with a given prefix."
+ (declare (string str prefix))
+ (string= str prefix :start1 0 :end1
+ (min (length prefix)
+ (length str))))
+
+
+(defun string-starts-with-char (begin str)
+ (equal (char str 0) begin))
+
+
+(defun string-until (str anchor)
+ "Returns a substring until the position of the passed anchor."
+ (declare (String str anchor))
+ (let ((pos (search anchor str)))
+ (if pos
+ (subseq str 0 pos)
+ str)))
+
+
+(defun string-after (str prefix)
+ "Returns the substring after the found prefix.
+ If there is no substring equal to prefix nil is returned."
+ (declare (String str prefix))
+ (let ((pos (search prefix str)))
+ (if pos
+ (subseq str (+ pos (length prefix)))
+ nil)))
\ No newline at end of file
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Wed Nov 17 16:41:59 2010
@@ -41,9 +41,9 @@
:depends-on ("exceptions")))
:depends-on ("constants" "base-tools"))
(:module "TM-SPARQL"
- :components ((:file "sparql"
- :depends-on ("sparql_tokenizer"))
- (:file "sparql_tokenizer"))
+ :components ((:file "sparql")
+ (:file "sparql_parser"
+ :depends-on ("sparql")))
:depends-on ("constants" "base-tools" "model"))
(:module "xml"
:components ((:module "xtm"
Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp (original)
+++ trunk/src/model/datamodel.lisp Wed Nov 17 16:41:59 2010
@@ -135,7 +135,6 @@
:list-instanceOf
:list-super-types
:in-topicmap
- :string-starts-with
:get-fragments
:get-fragment
:get-all-revisions
@@ -884,14 +883,6 @@
(slot-value construct (find-symbol "OID" 'elephant)))
-(defun string-starts-with (str prefix)
- "Checks if string str starts with a given prefix."
- (declare (string str prefix))
- (string= str prefix :start1 0 :end1
- (min (length prefix)
- (length str))))
-
-
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric mark-as-deleted (construct &key source-locator revision)
(:documentation "Mark a construct as deleted if it comes from the source
Modified: trunk/src/model/exceptions.lisp
==============================================================================
--- trunk/src/model/exceptions.lisp (original)
+++ trunk/src/model/exceptions.lisp Wed Nov 17 16:41:59 2010
@@ -17,10 +17,25 @@
:not-mergable-error
:missing-argument-error
:tm-reference-error
- :bad-type-error))
+ :bad-type-error
+ :missing-query-string-error
+ :sparql-parser-error))
(in-package :exceptions)
+
+(define-condition missing-query-string-error(error)
+ ((message
+ :initarg :message
+ :accessor message)))
+
+
+(define-condition sparql-parser-error(error)
+ ((message
+ :initarg :message
+ :accessor message)))
+
+
(define-condition inconsistent-file-error(error)
((message
:initarg :message
Modified: trunk/src/xml/rdf/exporter.lisp
==============================================================================
--- trunk/src/xml/rdf/exporter.lisp (original)
+++ trunk/src/xml/rdf/exporter.lisp Wed Nov 17 16:41:59 2010
@@ -8,7 +8,8 @@
;;+-----------------------------------------------------------------------------
(defpackage :rdf-exporter
- (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel)
+ (:use :cl :cxml :elephant :datamodel :isidorus-threading
+ :datamodel :base-tools)
(:import-from :constants
*rdf-ns*
*rdfs-ns*
Modified: trunk/src/xml/xtm/tools.lisp
==============================================================================
--- trunk/src/xml/xtm/tools.lisp (original)
+++ trunk/src/xml/xtm/tools.lisp Wed Nov 17 16:41:59 2010
@@ -275,15 +275,11 @@
(defun xpath-single-child-elem-by-qname (elem namespace-uri local-name)
- "Returns some child of elem that has qname (namespace-uri local-name) or
-nil if no such child exists."
+ "Returns some child of elem that has qname (namespace-uri local-name)
+ or nil if no such child exists."
(declare (dom:element elem))
- (find-if (lambda (el) (has-qname el namespace-uri local-name)) (dom:child-nodes elem))
- )
-
-
-(defun string-starts-with (begin str)
- (equal (char str 0) begin))
+ (find-if (lambda (el) (has-qname el namespace-uri local-name))
+ (dom:child-nodes elem)))
(defun xpath-select-location-path (elem list-of-qnames)
@@ -297,7 +293,7 @@
(cond
(list-of-qnames
(cond
- ((string-starts-with #\@ local-name)
+ ((string-starts-with-char #\@ local-name)
(list (dom:get-attribute-node-ns elem namespace-uri (string-left-trim "@" local-name))))
(t
(apply #'append
More information about the Isidorus-cvs
mailing list