Commit 335b6561 authored by Dave Cooper's avatar Dave Cooper

added syntax checker, Issue #145

parent 4a8a0015
......@@ -10,7 +10,8 @@
((:file "source/package") (:file "source/genworks")
(:file "source/presets") (:file "source/parameters")
(:file "source/metaclasses") (:file "source/utilities")
(:file "source/start") (:file "expanders/source/inputs")
(:file "source/start") (:file "source/syntax-checker")
(:file "expanders/source/inputs")
(:file "expanders/source/computed-slots")
(:file "expanders/source/functions")
(:file "expanders/source/methods")
......@@ -27,5 +28,7 @@
(:file "rest/source/base-rule-object") (:file "rest/source/bodies")
(:file "rest/source/ignore-errors-with-backtrace")
(:file "rest/source/init") (:file "rest/source/make-part")
(:file "rest/source/sequence") (:file "zzinit/source/initialize")
(:file "rest/source/sequence")
(:file "zzinit/source/initialize")
(:file "zzinit/source/zzinit")))
This diff is collapsed.
(in-package :gdl)
(defparameter *on-syntax-error* :warn "Keyword symbol. Can be either :warn or :error.")
(define-condition syntax-error (error)
((text :initarg :text :reader text)))
(defun syntax-error (name token message-key message)
(let ((text (format nil "Syntax error for class ~s.~%Offending token: ~s~%~a: ~a." name token message-key message)))
(ecase *on-syntax-error*
(:warn (warn text))
(:error (error 'syntax-error :text text)))))
(defun check-floating-string (name form)
"check for special case in which documentation isn't followed by symbol spec"
(when (stringp (first (last form)))
(syntax-error name (first (last form)) "Problem" "documentation string isn't followed by any message symbol")))
(defun check-form (name form predicate grammar)
"general function that, given a predicate, validates all tokens in a slot declaration form"
(dolist (token form)
(if (not (funcall predicate token))
(syntax-error name token "Valid Grammar" grammar))))
(defun check-input-slots (name form)
":input-slots grammar:
<form> = :input-slots (<token>*)
<token> = <string> | <symbol> | (<string>* <symbol> <expression>+ <behavior>*)
<behavior> = :settable | :defaulting
Also check for special case in which only strings without a symbol following."
(when form
(let ((behavior '(:settable :defaulting))
(grammar "
<form> = :input-slots (<token>*)
<token> = <string> | <symbol> | (<string>* <symbol> <expression>+ <behavior>*)
<behavior> = :settable | :defaulting"))
(flet ((valid-token (token)
(or (symbolp token)
(stringp token)
(and (consp token)
(let ((token (strip-strings token)))
(and (symbolp (first token))
;; RvD: this check still allows duplicate keys in tail of cons
(every
#'(lambda (token*) (member token* behavior))
(rest (rest token)))))))))
(check-form name form #'valid-token grammar)
(check-floating-string name form)
))))
(defun check-computed-slots (name form)
":computed-slots grammar:
<form> = :computed-slots (<token>*)
<token> = <string> | (<string>* <symbol> <expression>+ <behavior>+)
<behavior> = :settable | :uncached
Also check for special case in which only strings without a symbol following."
(when form
(let ((behavior '(:settable :uncached))
(grammar "
<form> = :computed-slots (<token>*)
<token> = <string> | (<string>* <symbol> <expression>+ <behavior>*)
<behavior> = :settable | :uncached"))
(flet ((valid-token (token)
(or (stringp token)
(and (consp token)
(let ((token (strip-strings token)))
(and (symbolp (first token))
;; RvD: unlike :input-slots, :computed-slots only allows one behavior keyword
;; RvD: otherwise GDL compiler throws warnings.
(or (not (rest (rest token)))
(and (= (length token) 3)
(member (third token) behavior)))
))))))
(check-form name form #'valid-token grammar)
(check-floating-string name form)
))))
(defun check-objects (name form &optional (hidden nil))
":(hidden-)objects grammar:
<form> = (hidden-):objects (<token>*)
<token> = (<string>* <symbol> <rule>*)
<rule> = <keyword> <expression>"
(when form
(let ((grammar (format nil "
<form> = :~aobjects (<token>*)
<token> = (<string>* <symbol> <rule>*)
<rule> = <keyword> <expression>" (if hidden "hidden-" ""))))
(flet ((valid-token (token)
(and (consp token)
(let ((token (strip-strings token)))
(and (symbolp (first token))
;; plist is already checked by define-object internals, but do it here anyway
(or (and (evenp (length (rest token)))
(every #'keywordp (plist-keys (rest token))))
(syntax-error name (rest token) "Problem" (format nil "Unvalid plist for slot ~s" (first token)))
t)
)))))
(check-form name form #'valid-token grammar)
))))
(defun check-functions (name form &optional (methods t))
":functions|:methods grammar:
<form> = :functions|:methods (<token>*)
<token> = (<string>* <symbol> <behavior>+ <list> <body>)
<behavior> = :cached | :cached-eql | :cached-= | :cached-eq | :cached-equal | :cached-equalp"
(when form
(let ((grammar (format nil "
<form> = :~a (<token>*)
<token> = (<string>* <symbol> <behavior>+ <list> <body>*)
<behavior> = :cached | :cached-eql | :cached-= | :cached-eq | :cached-equal | :cached-equalp"
(if methods "methods" "functions")))
(behavior '(:cached :cached-eql :cached-= :cached-eq :cached-equal :cached-equalp)))
(flet ((valid-token (token)
(and (consp token)
(let ((token (strip-strings token)))
(and (symbolp (first token))
(or (listp (second token))
(and (member (second token) behavior)
(listp (third token))))
)))))
(check-form name form #'valid-token grammar)
))))
(defun check-trickle-down-slots (name form)
":functions|:methods grammar:
<form> = :trickle-down-slots (<symbol>*)
"
(when form
(let ((grammar "<form> = :trickle-down-slots (<symbol>*)"))
(if (not (and (consp form)
(every #'symbolp form)))
(syntax-error name form "Valid Grammar" grammar)))))
(defun check-query-slots (name form)
"unknown what is is"
(declare (ignore name form))
t)
(defun check-documentation (name form)
"plist containing keys :description :author :examples :date :version"
(when form
(let ((valid-keys '(:description :author :examples :date :version)))
(when (not (and (consp form)
(evenp (length form))
(every #'(lambda (key) (member key valid-keys)) (plist-keys form))))
(syntax-error name form "Problem"
(format nil ":documentation is a plist which may contain the following keys: ~a" valid-keys))))))
(defun check-syntax (name
input-slots
computed-slots
objects
hidden-objects
functions
methods
documentation
trickle-down-slots
query-slots)
(check-input-slots name input-slots)
(check-computed-slots name computed-slots)
(check-objects name objects)
(check-objects name hidden-objects t)
(check-functions name functions)
(check-functions name methods t)
(check-trickle-down-slots name trickle-down-slots)
(check-query-slots name query-slots)
(check-documentation name documentation)
)
(gwl:define-package :gdl-lift-tests)
(in-package :gdl-lift-tests)
(define-condition not-raised (error)
;; Private condition to use inside assert-raises."
((expected-condition :initarg :expected-condition :reader expected-condition)
(raised-condition :initarg :raised-condition :reader raised-condition :initform nil)
(expression :initarg :expression :reader expression)
(msg :initarg :msg :reader msg))
(:report (lambda (condition stream)
(format stream "AssertionError: condition not raised.
Message: ~a
Expression: ~s
Expected: '~s
Raised: ~s
Print: ~a"
(msg condition)
(expression condition)
(expected-condition condition)
(raised-condition condition)
(raised-condition condition))
)))
(define-condition was-raised (error)
;; Private condition to use inside assert-raises."
((raised-condition :initarg :raised-condition :reader raised-condition)
(expression :initarg :expression :reader expression)
(msg :initarg :msg :reader msg))
(:report (lambda (condition stream)
(format stream "AssertionError: condition was raised.
Message: ~a
Expression: ~s
Raised: ~s
Print: ~a"
(msg condition)
(expression condition)
(raised-condition condition)
(raised-condition condition)
))))
(defmacro assert-raises (condition quoted msg)
"Custom test for quoted `define-object expresssion. Check that condition is raised"
`(handler-case
(progn (eval ,quoted)
;; will be caught and re-raised
(error 'not-raised))
(not-raised () (error 'not-raised
:expected-condition ',condition
:expression ,quoted
:msg ,msg))
(,condition () t)
(error (e) (error 'not-raised
:expected-condition ',condition
:raised-condition e
:expression ,quoted
:msg ,msg))
))
(defmacro assert-not-raises (quoted msg)
"Custom test for quoted `define-object expresssion. Check that not condition is raised"
`(handler-case
(eval ,quoted)
(error (e) (error 'was-raised :raised-condition e :expression ,quoted :msg ,msg))))
(defmacro defobj (key &rest body)
"Make a quick define-object code for testing."
;; still return quoted, we eval later
`(quote
(define-object foo ()
,key
(,@body))))
(define-object syntax-error-test ()
;; it's important that syntax-checking code and patches to define-object macros are loaded first!!!
:computed-slots
((regression-test-data
(let ((gdl::*on-syntax-error* :error))
;; ############
;; :input-slots
;; ############
(assert-not-raises (defobj :input-slots sym) "simple symbol")
(assert-not-raises (defobj :input-slots "doc" sym) "docstring followed by symbol")
(assert-not-raises (defobj :input-slots ("doc" sym)) "docstring followed by symbol")
(assert-not-raises (defobj :input-slots ("doc" sym 2)) "with default")
(assert-not-raises (defobj :input-slots ("doc" sym 2 :defaulting :settable)) "with behavior")
(assert-raises gdl::syntax-error
(defobj :input-slots 2)
"Invalid token")
(assert-raises gdl::syntax-error
(defobj :input-slots (1 sym))
"Invalid doc token")
(assert-raises gdl::syntax-error
(defobj :input-slots ("doc" 1 sym))
"Invalid second doc token")
(assert-raises gdl::syntax-error
(defobj :input-slots (sym 1 :settable :nonsense))
"Invalid behavior")
(assert-raises gdl::syntax-error
(defobj :input-slots sym "free-floating")
"free-floating string")
;; ###############
;; :computed-slots
;; ###############
(assert-not-raises (defobj :computed-slots "doc" (sym)) "docstring followed by symbol")
(assert-not-raises (defobj :computed-slots ("doc" sym)) "docstring followed by symbol")
(assert-not-raises (defobj :computed-slots ("doc" sym 2)) "with default")
(assert-not-raises (defobj :computed-slots ("doc" sym 2 :settable)) "with behavior")
(assert-raises gdl::syntax-error
(defobj :computed-slots 2)
"Invalid token")
(assert-raises gdl::syntax-error
(defobj :computed-slots sym)
"Symbol without default")
(assert-raises gdl::syntax-error
(defobj :computed-slots (1 sym))
"Invalid doc token")
(assert-raises gdl::syntax-error
(defobj :computed-slots ("doc" 1 sym))
"Invalid second doc token")
(assert-raises gdl::syntax-error
(defobj :computed-slots (sym 1 :nonsense))
"Invalid behavior")
(assert-raises gdl::syntax-error
(defobj :computed-slots sym "free-floating")
"free-floating string")
;; ########
;; :objects
;; ########
(assert-not-raises (defobj :objects ("doc" sym :type 'bar)) "valid :objects grammar")
(assert-raises gdl::syntax-error
(defobj :objects "doc")
"invalid docstring")
(assert-raises gdl::syntax-error
(defobj :objects sym)
"invalid symbol")
(assert-raises gdl::syntax-error
(defobj :objects 1)
"invalid symbol")
(assert-raises gdl::syntax-error
(defobj :objects (1 sym))
"invalid docstring")
(assert-raises gdl::syntax-error
(defobj :objects ("doc" sym 1))
"invalid plist")
;; ##########
;; :functions
;; ##########
(assert-not-raises (defobj :functions ("doc" sym :cached (bar) (+ bar 1))) "valid :functions grammar")
(assert-raises gdl::syntax-error
(defobj :functions "doc")
"invalid docstring")
(assert-raises gdl::syntax-error
(defobj :functions sym)
"invalid symbol position")
(assert-raises gdl::syntax-error
(defobj :functions 1)
"invalid token")
(assert-raises gdl::syntax-error
(defobj :functions (1 sym))
"invalid doctring")
(assert-raises gdl::syntax-error
(defobj :functions ("doc" sym :nonsense))
"invalid behavior")
(assert-raises gdl::syntax-error
(defobj :functions ("doc" sym 2))
"invalid parameter list")
;; ###################
;; :trickle-down-slots
;; ###################
(assert-not-raises (defobj :trickle-down-slots ) "valid :trickle-down-slots grammar")
(assert-not-raises (defobj :trickle-down-slots bar baz) "valid :trickle-down-slots grammar")
(assert-raises gdl::syntax-error
(defobj :trickle-down-slots 1 2)
"invalid tokens")
(assert-raises gdl::syntax-error
(defobj :trickle-down-slots (sym) sym)
"invalid nesting")
;; ##############
;; :documentation
;; ##############
(assert-not-raises (defobj :documentation ) "valid :documentation")
(assert-not-raises (defobj :documentation :author "Reinier van Dijk" :description "some test") "valid :documentation")
(assert-raises gdl::syntax-error
(defobj :documentation 1)
"invalid plist")
(assert-raises gdl::syntax-error
(defobj :documentation :nonsense 1)
"invalid keywords")
))))
;; (register-test-definition 'syntax-error-test)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment