For some time after I learned CL, I’d always go for a struct. After all,
defstruct is so easy to work with – you get so many useful accessors for
free!
(defstruct foo
a
b)
This gives us the type FOO, the functions MAKE-FOO, COPY-FOO and FOO-P
and the slot accessing functions FOO-A and FOO-B out of the box.
Compare that to the equivalent defclass and the only thing you get is the
type. There’s no copying function, the type needs to be passed around to
MAKE-INSTANCE, TYPEP and don’t even get me started on the verbosity of
SLOT-VALUE.
That said, at least this problem can be solved by using macros like WITH-SLOTS
or defclass* (readily available on Quicklisp).
However, there’s still the issue of performance. Because there’s no dynamic dispatch, structs are usually faster than classes - plus their functions can be inlined, and structs themselves can also be stack allocated.
What’s not there to like?
The big problem with structs, especially when you are still exploring things, is modifications. Change the above struct to the following:
(defstruct foo
x
a
b)
And SBCL will immediately complain with this:
WARNING: change in instance length of class FOO:
current length: 2
new length: 3
debugger invoked on a SIMPLE-ERROR in thread
#<THREAD "main thread" RUNNING {1004AC0203}>:
attempt to redefine the STRUCTURE-OBJECT class FOO incompatibly with the
current definition
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [CONTINUE ] Use the new definition of FOO, invalidating
already-loaded code and instances.
1: [RECKLESSLY-CONTINUE] Use the new definition of FOO as if it were
compatible, allowing old accessors to use new
instances and allowing new accessors to use old
instances.
2: [ABORT ] Exit debugger, returning to top level.
For your own sake, just abort (restart 2) or continue (restart 0). In no case shall ye recklessly continue, because then you are just asking for trouble – ok maybe try it just for fun, but don’t do this in production!
Classes, on the other hand, are born to be redefined. Add a new slot, or remove an existing one, your instances will keep working just fine.
And while classes may not be as performant as structs, their performance is good enough most of the time, even more so when you are exploring things. Here’s a good collection of articles on CLOS efficiency.
In conclusion, my opinion on this matter has done a 180-degree turn and today I
default to using a defclass when exploring new compound types.
SIMPLE-ARRAY,
SIMLPE-BASE-STRING, etc.) were passed to the encoding/decoding routines, but I
also wanted to support the more general types.
For example, the core encoding routine in qbase64, %ENCODE, which looks
something like this (simplified):
(defun %encode (bytes string)
(loop ;; over bytes and write to string
...))
goes through the BYTES array, taking groups of 3 octets each and writes the
encoded group of 4 characters into STRING.
If I declared its types like this:
(defun %encode (bytes string)
(declare (type (simple-array (unsigned-byte 8)) bytes))
(declare (type simple-base-string string))
(declare (optimize speed))
(loop ...))
SBCL would produce very fast code, but the function would no longer work for
either ARRAY or STRING:
And if I was to redefine the routine with more general types:
(defun %encode (bytes string)
(declare (type array bytes))
(declare (type string string))
(declare (optimize speed))
(loop ...))
the code produced would be significantly slower.
My experience with generics is limited, but it seemed that generics could solve this problem elegantly. However, Common Lisp doesn’t have generics, but it does support macros, so I came up with an ugly-but-gets-the-job-done hack.
I created a macro, DEFUN/TD, that would take all the different type combinations I wanted to optimize and support upfront:
(defun/td %encode (bytes string)
(((bytes (simple-array (unsigned-byte 8))) (string simple-base-string))
((bytes (simple-array (unsigned-byte 8))) (string simple-string))
((bytes array) (string string)))
(declare (optimize speed))
(loop ...))
and generate code which would dispatch over the type combinations, then use
LOCALLY to declare the types and splice the body in:
(defun %encode (bytes string)
(cond
((and (typep bytes '(simple-array (unsigned-byte 8)))
(typep string 'simple-base-string))
(locally
(declare (type bytes (simple-array (unsigned-byte 8))))
(declare (type string simple-base-string))
(declare (optimize speed))
(loop ...)))
((and (typep bytes '(simple-array (unsigned-byte 8)))
(typep string 'simple-string))
(locally
(declare (type bytes (simple-array (unsigned-byte 8))))
(declare (type string simple-string))
(declare (optimize speed))
(loop ...)))
((and (typep bytes 'array)
(typep string 'string))
(locally
(declare (type bytes array))
(declare (type string string))
(declare (optimize speed))
(loop ...)))
(t (error "Unsupported type combination"))))
The result is more generated code and an increase in the size of the Lisp image,
but now the loop is well optimized for each type combination given to
DEFUN/TD. The run-time dispatch might incur a slight penalty, but it is more
than offset by the gains made.
This was a fairly interesting problem that I hadn’t dealt with before, nevertheless it looked like a fairly common one, so I asked on the cl-pro list a couple of years ago how others solved this; Mark Cox pointed me to a few libraries:
All of these are quite interesting and attack more or less the same problem in different ways.
Is there a trick or two that I’ve missed? Feel free to tell me.
]]>PREPARE that
creates prepared statements for a PostgreSQL connection. It takes a SQL
query with placeholders ($1, $2, etc.) as input and returns a function which
takes one argument for every placeholder and executes the query.
The first time I used it, I did something like this:
(defun run-query (id)
(funcall (prepare "SELECT * FROM foo WHERE id = $1") id))
Soon after, I realized that running this function every time would generate a new prepared statement instead of re-using the old one. Let’s look at the macro expansion:
(macroexpand-1 '(prepare "SELECT * FROM foo WHERE id = $1"))
==>
(LET ((POSTMODERN::STATEMENT-ID (POSTMODERN::NEXT-STATEMENT-ID))
(QUERY "SELECT * FROM foo WHERE id = $1"))
(LAMBDA (&REST POSTMODERN::PARAMS)
(POSTMODERN::ENSURE-PREPARED *DATABASE* POSTMODERN::STATEMENT-ID QUERY)
(POSTMODERN::ALL-ROWS
(CL-POSTGRES:EXEC-PREPARED *DATABASE* POSTMODERN::STATEMENT-ID
POSTMODERN::PARAMS
'CL-POSTGRES:LIST-ROW-READER))))
T
ENSURE-PREPARED checks if a statement with the given statement-id
exists for the current connection. If yes, it will be re-used, else a new one is
created with the given query.
The problem is that the macro generates a new statement id every time it is
run. This was a bit surprising, but the fix was simple: capture the function
returned by PREPARE once, and use that instead.
(defparameter *prepared* (prepare "SELECT * FROM foo WHERE id = $1"))
(defun run-query (id)
(funcall *prepared* id))
You can also use Postmodern’s DEFPREPARED instead, which similarly defines a
new function at the top-level.
This works well, but now are using top-level forms instead of the nicely encapsulated single form we used earlier.
To fix this, we can use LOAD-TIME-VALUE.
(defun run-query (id)
(funcall (load-time-value (prepare "SELECT * FROM foo WHERE id = $1")) id))
LOAD-TIME-VALUE is a special operator that
By wrapping PREPARE inside LOAD-TIME-VALUE, we get back our encapsulation
while ensuring that a new prepared statement is generated only once (per
connection), until the next time RUN-QUERY is recompiled.
To avoid the need to wrap PREPARE every time, we can create a converience
macro and use that instead:
(defmacro prepared-query (query &optional (format :rows))
`(load-time-value (prepare ,query ,format)))
(defun run-query (id)
(funcall (prepared-query "SELECT * FROM foo WHERE id = $1") id))
This only works for compiled code. As mentioned earlier, the form wrapped inside
LOAD-TIME-VALUE is evaluated once only if you compile it. If uncompiled, it is
evaluated every time so this solution will not work there.
Another thing to remember about LOAD-TIME-VALUE is that the form is evaluated
in the null lexical environment. So the form cannot use any lexically scoped
variables like in the example below:
(defun run-query (table id)
(funcall (load-time-value
(prepare (format nil "SELECT * FROM ~A WHERE id = $1" table)))
id))
Evaluating this will signal that the variable TABLE is unbound.
But how exactly does Chronicity work? In this post, we’ll dig into its innards and get a sense of the steps involved in writing it.
If you want to hack into Chronicity, or write your own NLP date parser, this might help.
Note: credit for Chronicity’s architecture goes to the Ruby library Chronic. It served both as an inspiration and as the implementation reference.
Broadly, Chronicity follows these steps to parse date and time strings:
We normalize the text before tokenizing it by doing the following:
All of this is accomplished by the PRE-NORMALIZE function. To
convert numeric words to numbers the NUMERIZE function is
used. One caveat: do not immediately normalize the term “second” – it can either
mean the ordinal number or the unit of time. So we wait until after tokenization
(see pre-process tokens) to resolve this ambiguity.
CHRONICITY> (pre-normalize "tomorrow at seven")
"next day at 7"
CHRONICITY> (pre-normalize "20 days ago")
"20 days past"
Next we assign a token to each word in the normalized text.
(defclass token ()
((word :initarg :word
:reader token-word)
(tags :initarg :tags
:initform nil
:accessor token-tags)))
(defun create-token (word &rest tags)
(make-instance 'token
:word word
:tags tags))
As you can see, besides the word, a token also contains a list of tags. Each tag indicates a possible way to interpret the given word or number. Take the phrase “20 days ago”. The number 20 can be interpreted in many ways:
Remember, we are still in the tokenization phase so we don’t know which interpretation is correct. So we will assign all four tags to the token for this number.
Each tag is a subclass of the TAG class, which is defined as follows.
(defclass tag ()
((type :initarg :type
:reader tag-type)
(now :initarg :now
:accessor tag-now
:initform nil)))
(defun create-tag (class type &key now)
(make-instance class :type type :now now))
The slot TYPE is a misnomer – it actually indicates the designated value of
the token for this tag. For example, the TYPE for the year 2020 above will
be the integer 2020. For the time 8 PM it will be an object denoting the time.
The slot NOW has the current timestamp. It is used by some tag classes like
REPEATER for date-time computations (discussed later).
The various subclasses of TAG are:
SEPARATOR – Things like slash “/”, dash “-“, “in”, “at”, “on”,
etc.ORDINAL – Numbers like 1st, 2nd, 3rd, etc.SCALAR – Simple numbers like 1, 5, 10, etc. It is further
subclassed by SCALAR-DAY (1-31), SCALAR-MONTH (1-12) and SCALAR-YEAR. A
token for any number will usually contain the SCALAR tag plus one or more of
the subclassed tags as applicable.POINTER – Indicates whether we are looking forwards (“hence”,
“after”, “from”) or backwards (“ago”, “before”). These words are normalized
to “future” and “past” before they are tagged.GRABBER – The terms “this”, “last” and “next” (as in this month
or last month).REPEATER – Most of the date and time terms are tagged using this
class. This is described in more detail below.There are a number of subclasses of REPEATER to
indicate the numerous date and time terms. For example:
REPEATER-YEAR, REPEATER-MONTH, REPEATER-WEEK, REPEATER-DAY.REPEATER-MONTH-NAME is used to indicate month names like “jan” or “january”.REPEATER-DAY-NAME indicates day names like “monday”.REPEATER-TIME is used to indicate time strings like 20:00.REPEATER-DAY-PORTION.In addition, all the REPEATER subclasses need to implement a few methods that
are needed for date-time computations.
R-NEXT – Given a repeater and a pointer i.e. :PAST or :FUTURE, returns a
time span in the immediate past or future relative to the NOW slot. For
example, assume the date in NOW is 31st December 2018.
(r-next repeater :past) for a REPEATER-MONTH will return a time span
starting 1st November 2018 and ending at 30th November.(r-next repeater :future) will return a span for all of January 2019.REPEATER-DAY this would have returned 30th December for
:PAST and 1st January for the :FUTURE pointer.R-THIS is similar to R-NEXT except it works in the current context. The
width of the span also depends on whether direction of the pointer.
(r-this repeater :past) for a REPEATER-DAY will return a span from the
start of day until now.(r-this repeater :future) will return a span from now until the end of
day.(r-this repeater :none) will return the whole day today.R-OFFSET – Given a span, a pointer and an amount, returns a new span offset
from the given span. The offset is roughly the amount mulitplied by the width
of the repeater.Now we can put the whole tokenization and tagging piece together:
(defun tokenize (text)
(mapcar #'create-token
(cl-ppcre:split #?r"\s+" text)))
(defun tokenize-and-tag (text)
(let ((tokens (tokenize text)))
(loop
for type in (list 'repeater 'grabber 'pointer 'scalar 'ordinal 'separator)
do (scan-tokens type tokens))
tokens))
As you can see, computing the tags for each token is accomplished by the
SCAN-TOKENS. This is a generic function specialized on the class name of the
tag.
One of the methods implementing SCAN-TOKENS is shown below.
(defmethod scan-tokens ((tag (eql 'grabber)) tokens)
(let ((scan-map '(("last" :last)
("this" :this)
("next" :next))))
(dolist (token tokens tokens)
(loop
for (regex value) in scan-map
when (cl-ppcre:scan regex (token-word token))
do (tag (create-tag 'grabber value) token)))))
(defmethod tag (tag token)
(push tag (token-tags token)))
Going back to our original example, for the text “20 days ago”, these are the tags set for each token (after normalization).
Token Tags
----- ----
20 [SCALAR-YEAR, SCALAR-DAY, SCALAR, REPEATER-TIME]
days [REPEATER-DAY]
past [POINTER]
We are almost ready to run pattern matching to figure out the input date, but first, we need to resolve the ambiguity related to the term second that we faced during normalization. At that time, we did not convert it to the number 2 since it could refer to either the unit of time or the number.
Now with tokenization done, we resolve this ambiguity with a simple hack: if the
term second is followed by a repeater (i.e. month, day, year, january, etc.), we
assume that it is the ordinal number 2nd and not the unit of time. See
PRE-PROCESS-TOKENS for more details.
The last piece of the puzzle is pattern matching. Armed with tokens and their corresponding tags, we define several date and time patterns that we know of and try to match them to their input tokens.
First we name a few pattern classes – each pattern we define belongs to one of these classes.
DATE – patterns that match an absolute date and time e.g. “1st January”,
“January 1 at 2 PM”, etc.ANCHOR – patterns that typically involve a grabber e.g. “yesterday”,
“tuesday” “last week”, etc.ARROW – patterns like “2 days from now”, “3 weeks ago”, etc.NARROW – patterns like “1st day this month”, “3rd wednesday in 2007”, etc.TIME – simple time patterns like “2 PM”, “14:30”, etc.A pattern, at its simplest, is just a list of tag classes. A list of input tokens successfully matches a pattern if, for every token, at least one of its tags is an instance of the tag class mentioned at the corresponding position in the pattern. For example, the text “20 days ago” had these tags:
Token Tags
----- ----
20 [SCALAR-YEAR, SCALAR-DAY, SCALAR, REPEATER-TIME]
days [REPEATER-DAY]
past [POINTER]
It will match any of these patterns:
(scalar repeater pointer)
(scalar repeater-day pointer)
((? scalar) repeater pointer)
The last example shows a pattern with an optional tag – (? scalar). It will
match tokens with or without the scalar e.g. both “20 days ago” and “week ago”
will match.
Our pattern matching engine also allows us to match an entire pattern class. For example,
(repeater-month-name scalar-day (? separator-at) (? p time))
(? p time) here means that any pattern that belongs to the TIME pattern
class can match. So all of “January 1 at 12:30”, “January 1 at 2 PM” and
“January 1 at 6 in the evening” will match without us needing to duplicate all
the time patterns.
Note: There’s one limitation – a pattern class can only be specified at the
end of a pattern in Chronicity. So a pattern like (repeater (p time) pointer)
won’t work. This will be fixed in the future.
Each pattern has a handler function that decides how to convert the matching tokens to a date span.
A pattern and its handler function are defined using the
DEFINE-HANDLER macro. It assigns one or more patterns to a
pattern class, and if either of these patterns match, the function body is
run. Its general form is:
(define-handler (pattern-class)
(tokens-var)
(pattern1 pattern2 ...)
... body ...
)
An example handler is shown below.
(define-handler (date)
(tokens)
((repeater-month-name scalar-year))
(let* ((month-name (token-tag-type 'repeater-month-name (first tokens)))
(month (month-index month-name))
(year (token-tag-type 'scalar-year (second tokens)))
(start (make-date year month)))
(make-span start (datetime-incr start :month))))
Most handler functions will use make use of the the repeater methods R-NEXT,
R-THIS and R-OFFSET that we described above.
Chronicity implements this pattern matching logic in the
TOKENS-TO-SPAN function. All the patterns and their handler
functions are defined inside handler-defs.lisp. Patterns defined earlier in
the file get precedence over those defined later. If you add, remove or modify a
handler, you should reload the whole file rather than just evaluating that
handler’s definition.
Finally, we put everything together.
(defun parse (text &key (guess t))
(let ((tokens (tokenize-and-tag (pre-normalize text))))
(pre-process-tokens tokens)
(values (guess-span (tokens-to-span tokens) guess) tokens)))
By default PARSE will return a timestamp instead of a time span. This depends
on the value passed to the :GUESS keyword – see the GUESS-SPAN function to
see how it is interpreted. If you want to return a time span send NIL instead.
The second value that this function returns is the list of tokens alongwith all its tags. This is useful for debugging Chronicity results in the REPL.
CHRONICITY> (parse "20 days ago")
@2018-12-12T12:01:53.758578+05:30
(#<TOKEN 20 [SCALAR-YEAR, SCALAR-DAY, SCALAR, REPEATER-TIME] {1007639243}>
#<TOKEN days [REPEATER-DAY] {10076AF5D3}> #<TOKEN past [POINTER] {1007553443}>)
CHRONICITY> (parse "20 days ago" :guess nil)
#<SPAN 2018-12-12T00:00:00.000000+05:30..2018-12-13T00:00:00.000000+05:30>
(#<TOKEN 20 [SCALAR-YEAR, SCALAR-DAY, SCALAR, REPEATER-TIME] {1001B78BC3}>
#<TOKEN days [REPEATER-DAY] {1001B78C03}> #<TOKEN past [POINTER] {1001B78C43}>)
The actual PARSE function has a few more bells and whistles than the one
defined here:
:ENDIAN-PREFERENCE to parse ambiguous dates as dd/mm (:LITTLE) or mm/dd
(:MIDDLE):AMBIGUOUS-TIME-RANGE to specify whether a time like 5:00 is in the morning
(AM) or evening (PM).:CONTEXT can be :PAST, :FUTURE or :NONE. This determines the time span
returned for strings like “this day”. See the definition of R-THIS above.Here’s a brief summary: a promise is an object that acts as a proxy for a result that is initially unknown, usually because the computation of its value is yet incomplete.1 In other words, they allow you to transform an async program from continuation passing style:2
getTweetsFor("domenic", function (err, results) {
// the rest of your code goes here.
});
to one where your functions return an object which represents the eventual results of that operation:
var promiseForTweets = getTweetsFor("domenic");
promiseForTweets.then(function (results) {
// success handler
}, function (error) {
// error handler
});
The function then allows you to add a success and an error handler
to a promise. When the promise is fulfilled (i.e. the computation
completes successfully), the result is passed to the success
handler. And if the promise fails (the computation errors out), the
error is sent to the error handler.
There’s more though. then returns a new promise. That promise is
fulfilled when the relevant handler returns successfully and gets
rejected when it errors out. In addition, if the handler itself
returns a promise, the state of the promise returned by then depends
on this new promise.
All of this allows you to write asynchronous code:
getTweetsFor("domenic") // promise-returning function
.then(function (tweets) {
var shortUrls = parseTweetsForUrls(tweets);
var mostRecentShortUrl = shortUrls[0];
return expandUrlUsingTwitterApi(mostRecentShortUrl); // promise-returning function
})
.then(httpGet) // promise-returning function
.then(
function (responseBody) {
console.log("Most recent link text:", responseBody);
},
function (error) {
console.error("Error with the twitterverse:", error);
}
);
that parallels the synchronous code:
try {
var tweets = getTweetsFor("domenic"); // blocking
var shortUrls = parseTweetsForUrls(tweets);
var mostRecentShortUrl = shortUrls[0];
var responseBody = httpGet(expandUrlUsingTwitterApi(mostRecentShortUrl)); // blocking x 2
console.log("Most recent link text:", responseBody);
} catch (error) {
console.error("Error with the twitterverse: ", error);
}
which is much nicer than the callback hell that you get otherwise.
What I have summarized here doesn’t really do justice to the subject, so if all of this is not very clear, do go through Domenic’s post to get a better idea.
Before we look at promises in Lisp, its worth seeing what a synchronous version of the Javascript code above might look like in Common Lisp:
(handler-case
(let* ((tweets (get-tweets-for user))
(short-urls (parse-tweets-for-urls tweets))
(expanded-url (expand-url-using-twitter-api (elt short-urls 0)))
(response-body (http-get expanded-url)))
(format t "Most recent link text: ~A~%" response-body))
(error (c) (format t "Got error: ~A~%" c)))
Assume that we have an implementation of promises like the one described above3, how would our promises based code look?
(then (then (then (get-tweets-for user)
(lambda (tweets)
(let ((short-urls (parse-tweets-for-urls tweets)))
(expand-url-using-twitter-api (elt short-urls 0)))))
#'http-get)
(lambda (body)
(format t "Most recent link text: ~A~%" body))
(lambda (error)
(format t "Got an error: ~A~%" error)))
Certainly not as good as Javascript. We could do a little better by
binding the promises in a LET*:
(let* ((tweets-promise (get-tweets-for user))
(short-urls-promise (then tweets-promise (lambda (tweets)
(parse-tweets-for-urls tweets))))
(expanded-url-promise (then short-urls-promise
(lambda (short-urls)
(expand-url-using-twitter-api (elt short-urls 0)))))
(response-body-promise (then expanded-url-promise #'http-get)))
(then response-body-promise
(lambda (response-body)
(format t "Most recent link text: ~A~%" response-body))
(lambda (error)
(format t "Got an error: ~A~%" error))))
But the result still leaves a lot to be desired. If only Lisp had the dot notation like Javascript…
Lisp doesn’t have the dot notation, but it does have another trick up its sleeve – macros. Can macros help us bridge the gap between the synchronous and async variants?
Let’s start with a simple macro, PROMISE-VALUES-BIND:
(defmacro promise-values-bind (var-list form &body body)
(let ((values (gensym "VALUES-")))
`(multiple-value-call
(lambda (&rest ,values)
(if (promisep (first ,values))
(then (first ,values)
(lambda ,var-list
,@body))
(destructuring-bind ,var-list
,values
,@body)))
,form)))
This macro is quite similar to MULTIPLE-VALUE-BIND. It evalues the
given form, and binds its values to the variables in var-list. If
the form returned a promise as its first value, then instead of
binding immediately, it waits for the promise to be fulfilled and
binds var-list to the resolved values.
(promise-values-bind (quotient remainder)
(values 10 3)
(format t "First: ~A, Second: ~A~%" quotient remainder))
;; =>
; First: 10, Second: 3
NIL
(let ((promise (make-promise)))
(promise-values-bind (quotient remainder)
promise
(format t "First: ~A, Second: ~A~%" quotient remainder))
promise)
;; =>
#<PROMISE Un {1004F93643}>
(fulfill * 10 3)
;; =>
; First: 10, Second: 3
NIL
Using PROMISE-VALUES-BIND, we write a promise based variant of
PROGN. We will give it the same name but define it in a new package,
PCL.
(defmacro pcl:progn (&body forms)
(cond ((null forms) nil)
((null (rest forms)) (first forms))
(t (let ((x (gensym "X-")))
`(promise-values-bind (&rest ,x)
,(first forms)
(declare (ignore ,x))
(pcl:progn ,@(rest forms)))))))
Just like its CL counterpart, PCL:PROGN evaluates the given forms
sequentially. However if any of the forms returns a promise, this
macro waits for the promise to be resolved before evaluating the next
form.
(let ((start (get-universal-time)))
(flet ((delta-now ()
(format t "~&t + ~A sec~%" (- (get-universal-time) start))))
(pcl:progn (princ 1)
(delta-now)
(pcl:sleep 2)
(princ 2)
(delta-now)
(princ 3))))
; 1
; t + 0 sec
; 2
; t + 2 sec
; 3
The function PCL:SLEEP schedules a timer on a runloop and returns a
promise that is resolved when the timer expires. In this example, the
last two forms are executed only after the promise returned by
PCL:SLEEP is resolved.
Moreover, if any form signals an error, or any promise is rejected, the remaining forms are not evaluated.
(let ((start (get-universal-time)))
(flet ((delta-now ()
(format t "~&t + ~A sec~%" (- (get-universal-time) start))))
(pcl:progn (princ 1)
(delta-now)
(pcl:sleep 2)
(princ 2)
(error "foo")
(delta-now)
(princ 3))))
; 1
; t + 0 sec
; 2
;; At this point, the debugger is invoked with #<SIMPLE-ERROR "foo" {1007381233}>
Next up is PCL:LET*, our variant of LET*. Bindings are performed
sequentially, and if an init-form returns a promise, the binding is
delayed until the promise is resolved. Also, the body of PCL:LET* is
evaluated within the context of PCL:PROGN instead of PROGN.4
(defmacro pcl:let* (bindings &body body)
(if (null bindings)
`(pcl:progn ,@body)
(let ((binding (first bindings)))
`(promise-values-bind (,(first binding))
,(second binding)
(pcl:let* ,(rest bindings)
,@body)))))
(pcl:let* ((a (pcl:progn (pcl:sleep 1) 10))
(b (pcl:progn (pcl:sleep 2) 20)))
(print (+ a b)))
; 30
And PCL:HANDLER-CASE is the promised counterpart of HANDLER-CASE.
(defmacro pcl:handler-case (expression &rest clauses)
(let ((values (gensym "VALUES-"))
(c (gensym "C-"))
(clauses (mapcar (lambda (clause)
(destructuring-bind (type (&rest vars) &body body)
clause
`(,type ,vars (pcl:progn ,@body))))
clauses)))
`(handler-case
(multiple-value-call
(lambda (&rest ,values)
(if (promisep (first ,values))
(then (first ,values)
nil
(lambda (,c)
(handler-case (signal ,c)
,@clauses)))
(values-list ,values)))
,expression)
,@clauses)))
With these macros in place, its time to see the result. Our promise based async code looks like this:
(pcl:handler-case
(pcl:let* ((tweets (get-tweets-for user))
(short-urls (parse-tweets-for-urls tweets))
(expanded-url (expand-url-using-twitter-api (elt short-urls 0)))
(response-body (http-get expanded-url)))
(format t "Most recent link text: ~A~%" response-body))
(error (c) (format t "Got error: ~A~%" c)))
Except for the change in symbol packages, our async code looks identical to the synchronous code. While the rest of the world waits for the language gods to provide the right syntactic tools, Lispers can just write macros 😄
These were just three forms, we can go a lot further than this. Add
promised counterparts for a few more special forms and macros like
UNWIND-PROTECT, LAMBDA, DEFUN, IF, etc. and you end up with a
set that starts to become useful.
Add promised variants of blocking I/O functions like READ-CHAR,
WRITE-CHAR, READ-BYTES, etc. and you end up with a nice little
async I/O framework.5
Debugging is a bit of a challenge with promises. Backtraces become pretty much useless, although that’s usually the case with callback hell too. Its also not as convenient to step through an async program as it is with synchronous code.
However, all said and done, the combination of macros and promises still holds great promise 😉
Source code to accompany this post is available on github. It contains a working implementation of promises, though you shouldn’t use it to write any serious code (try Blackbird if you want a practical implementation of promises).
Discuss on Hacker News or /r/lisp.
Source for the Javascript code examples and most of the content in the first section is Domenic’s aforementioned post. ↩
Since Lisp functions can return multiple values, the success handler for the THEN block in Lisp could be sent multiple arguments instead of just one. ↩
Handling of the body in PCL:LET* is incomplete here. LET/LET* allow optional DECLARE forms to precede the body, so PCL:LET* should too. I have chosen to ignore this but it shouldn’t be very hard to do. ↩
Not sure if such a framework exists in CL today. cl-async seems to do some of it but not all. ↩
Reader macros are perhaps not as famous as ordinary macros. While macros are a great way to create your own DSL, reader macros provide even greater flexibility by allowing you to create entirely new syntax on top of Lisp.
Paul Graham explains them very well in On Lisp (Chapter 17, Read-Macros):
The three big moments in a Lisp expression’s life are read-time, compile-time, and runtime. Functions are in control at runtime. Macros give us a chance to perform transformations on programs at compile-time. …read-macros… do their work at read-time.
Macros and read-macros see your program at different stages. Macros get hold of the program when it has already been parsed into Lisp objects by the reader, and read-macros operate on a program while it is still text. However, by invoking read on this text, a read-macro can, if it chooses, get parsed Lisp objects as well. Thus read-macros are at least as powerful as ordinary macros.
(Note that read-macros and reader macros mean the same thing)
The Lisp reader is the thing that parses and translates raw text into an AST. In Lisp, the AST is better known as an s-expression (or sexp) – its either an atom or a list.
Reader macros allow you to modify the behaviour of the Lisp reader.
Not only can you modify the behaviour of the Lisp reader, you can also invoke it. The simplest way to invoke the Lisp reader is to call the function READ. When you call READ with no arguments, it reads text from the standard input and returns an s-expression as soon as it fully parses one.
> (read)
;; Provide this input: foo
FOO
> (read)
;; Input: (foo 1 2 3)
(FOO 1 2 3)
The full syntax of READ looks like this:
(read &optional input-stream eof-error-p eof-value recursive-p) => object
All the arguments to READ are optional. The first is the input stream; eof-error-p and eof-value specify end of file handling; recursive-p should be set to true whenever READ is called from inside another call to READ. When implementing reader macros, recursive-p should always be true.
One of the simplest (and earliest) examples of a reader macro in Lisp is the single quote character '. This reader macro translates an expression of the form '<some-form> into (quote <some-form>).
'foo ;; translated to (quote foo)
'(1 2 3) ;; translated to (quote (1 2 3))
Simply put, the single quote character ' is a little bit of syntactic sugar added on top of Lisp. Reader macros do just that – allow you to add syntactic sugar to Lisp. What makes them so powerful is that, just like ordinay macros, you write reader macros in Lisp itself. For example, ' could be defined as:
(defun single-quote-reader (stream char)
(declare (ignore char))
(list (quote quote) (read stream t nil t)))
(set-macro-character #\' #'single-quote-reader)
SET-MACRO-CHARACTER makes the Lisp reader associate the single quote character ' with the function single-quote-reader. Whenever the reader encounters ', it calls single-quote-reader. This function takes two arguments – the input stream and the character in the stream that triggered the call. char will always be ' in this case.
Let’s trace step by step how this works. Assume we call READ on the following form:
> (read)
;; Input: 'foo
When READ is invoked, this is how the input stream looks:
'foo
^
The current position of the stream is denoted by ^. When READ is called, the next character in the stream is the quote. The reader reads this character, looks for its reader macro function, finds single-quote-reader and calls it. Just before single-quote-reader is called, this is how the stream looks:
'foo
^
single-quote-reader calls READ again. The inner call to READ returns the symbol foo, so the return value of this function is the sexp (quote foo) (usually printed by the Lisp printer as 'foo).
After single-quote-reader returns, the stream pointer moves beyond foo. [1]
'foo
^
Let’s work with a more complicated example. Let’s make the Lisp reader recognize JSON syntax.
> [1, 2, "foo"]
#(1 2 "foo")
> { "foo": 1, "bar": 2 }
#<HASH-TABLE :TEST EQUAL :COUNT 2 {1004EA5DD3}>
We define a few constants to work with.
(defconstant +left-bracket+ #\[)
(defconstant +right-bracket+ #\])
(defconstant +left-brace+ #\{)
(defconstant +right-brace+ #\})
(defconstant +comma+ #\,)
(defconstant +colon+ #\:)
To read JSON arrays, we dispatch the left bracket to read-left-bracket.
(defun read-left-bracket (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character +comma+ 'read-separator)
...
))
(set-macro-character +left-bracket+ 'read-left-bracket)
Note that I haven’t provided a complete definition for read-left-bracket yet. The readtable is an object that stores the association between characters and their reader macro functions, if any. *READTABLE* is a dynamic variable that specifies the current readtable. read-left-bracket binds the current readtable to a copy of itself, and causes the comma character , to be associated with read-separator (which we will see shortly). The reason we copy and rebind the current readtable is to avoid clobbering the readtable entry for comma outside of the dynamic scope of read-left-bracket.
Here’s the complete definition for read-left-bracket:
(defun read-next-object (separator delimiter
&optional (input-stream *standard-input*))
(flet ((peek-next-char () (peek-char t input-stream t nil t))
(discard-next-char () (read-char input-stream t nil t)))
(if (and delimiter (char= (peek-next-char) delimiter))
(progn
(discard-next-char)
nil)
(let* ((object (read input-stream t nil t))
(next-char (peek-next-char)))
(cond
((char= next-char separator) (discard-next-char))
((and delimiter (char= next-char delimiter)) nil)
(t (error "Unexpected next char: ~S" next-char)))
object))))
(defun read-left-bracket (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character +comma+ 'read-separator)
(loop
for object = (read-next-object +comma+ +right-bracket+ stream)
while object
collect object into objects
finally (return `(vector ,@objects)))))
The bulk of the work of reading JSON objects is done by read-next-object – read-left-bracket calls this function repeatedly until it returns NIL. The list of objects is then transformed into (vector obj1 obj2 ...) which, at runtime, will return a Lisp vector.
read-next-object takes three arguments: a delimiter, which indicates the end of a JSON array or object (i.e. right bracket or right brace); a separator, which separates objects inside a JSON array (comma) or object (comma or colon) and an optional stream argument that defaults to standard input. When read-next-object is first called inside an array the stream would be positioned just before the first object.
[1, 2, "foo"]
^
read-next-object parses and returns the first object (the number 1 in this case), and positions the stream before the next object, discarding the separator. If there was any whitespace before the first object, it would be discarded.
[1, 2, "foo"]
^
This cycle repeats until read-next-object reads the last object in the array, "foo". Since the next non-whitespace character after reading "foo" is not the separator but rather the delimiter, read-next-object returns "foo" but doesn’t try to read past the delimiter.
[1, 2, "foo"]
^
The last call to read-next-object notices that the next character is the delimiter. It moves the stream past the delimiter and returns NIL, which indicates to read-left-bracket that all the objects in the array have been read. Since the stream pointer is now positioned after the delimiter, the reader is now free to read a new object from the input stream.
[1, 2, "foo"]
^
This is how we define read-separator, the reader macro function for comma. This function signals an error whenever it is called – it is never meant to be called directly by the reader.
(defun read-separator (stream char)
(declare (ignore stream))
(error "Separator ~S shouldn't be read alone" char))
You might ask, if the separator is never meant to be read directly by the reader, why bother associating it with a macro function? The thing is, its not the macro function that’s important – what we really want to do is tell the Lisp reader that the separator is a terminating macro character. If this were not done, the Lisp reader could unwittingly treat the separator as part of the last object if there was no whitespace between the two. e.g. in [foo, ...], the first object would be read as foo, instead of foo if comma was not a terminating macro character. [2]
Lastly, we also need to define a macro function for the right bracket. This needs to be done for the same reason we needed to define a macro function for the separator – so that we can tell the Lisp reader that it is a terminating macro character.
(defun read-delimiter (stream char)
(declare (ignore stream))
(error "Delimiter ~S shouldn't be read alone" char))
(set-macro-character +right-bracket+ 'read-delimiter)
Now we have everything in place to read a JSON array in Lisp. Time for some tests.
> []
#()
> [1, 2, 3]
#(1 2 3)
> [ "foo", "bar", "baz" ]
#("foo" "bar" "baz")
> [1, 2, "foo"]
#(1 2 "foo")
Since we recursively call READ to read individual objects, nesting also works.
> [1, 2, [3, 4]]
#(1 2 #(3 4))
We can even use Lisp forms inside a JSON array, and they will work just fine.
> (let ((x 123) (y "foo")) [x, y])
#(123 "foo")
Remember that you can invoke the reader by calling READ, so you can always see the generated sexp for yourself.
> (read)
;; Input: [1, 2, "foo"]
(VECTOR 1 2 "foo")
> (read)
;; Input: (let ((x 123) (y "foo")) [x, y])
(LET ((X 123) (Y "foo"))
(VECTOR X Y))
Reading an object is not that different from reading an array. First we define a convenience function to create Lisp hash tables which will be used by read-left-brace, the macro function for the left brace.
(defun create-json-hash-table (&rest pairs)
(let ((hash-table (make-hash-table :test #'equal)))
(loop for (key . value) in pairs
do (setf (gethash key hash-table) value))
hash-table))
And here’s read-left-brace. Note that this function also relies on read-next-object to get the bulk of its work done.
(defun read-left-brace (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character +comma+ 'read-separator)
(set-macro-character +colon+ 'read-separator)
(loop
for key = (read-next-object +colon+ +right-brace+ stream)
while key
for value = (read-next-object +comma+ +right-brace+ stream)
collect `(cons ,key ,value) into pairs
finally (return `(create-json-hash-table ,@pairs)))))
(set-macro-character +left-brace+ 'read-left-brace)
Finally, we also associate right brace with a macro function.
(set-macro-character +right-brace+ 'read-delimiter)
Time for some more tests.
CL-USER> {}
#<HASH-TABLE :TEST EQUAL :COUNT 0 {1005EEEBE3}>
> { "foo": 1, "bar": 2, "baz": 3 }
#<HASH-TABLE :TEST EQUAL :COUNT 3 {1004DC3953}>
We can also nest objects and arrays.
> [{"foo": 1}, "bar", {"baz": [2, 3]}]
#(#<HASH-TABLE :TEST EQUAL :COUNT 1 {10062D4D83}> "bar"
#<HASH-TABLE :TEST EQUAL :COUNT 1 {10062D5283}>)
The generated sexp:
> (read)
{ "foo": 1, "bar": 2, "baz": 3 }
(CREATE-JSON-HASH-TABLE (CONS "foo" 1) (CONS "bar" 2) (CONS "baz" 3))
Our JSON reader can handle numbers, strings, objects and arrays fairly well. However, it can still not handle three primitives in JSON – true, false, and null. This is fairly easy to fix. When the reader encounters these JSON primitives, it interprets them as Lisp symbols. All we have to do is transform these into an appropriate Lisp value. To this end, we define a function transform-primitive.
(defun transform-primitive (value)
(if (symbolp value)
(cond
((string-equal (symbol-name value) "true") t)
((string-equal (symbol-name value) "false") nil)
((string-equal (symbol-name value) "null") nil)
(t value))
value))
transform-primitive transforms both false and null from JSON to NIL in Lisp. That’s because in Lisp, the two are represented by the same value. You can always choose a different representation if you want.
We can start using transform-primitive in our reader macro functions now.
(defun read-left-bracket (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character +comma+ 'read-separator)
(loop
for object = (read-next-object +comma+ +right-bracket+ stream)
while object
collect (transform-primitive object) into objects
finally (return `(vector ,@objects)))))
(defun read-left-brace (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character +comma+ 'read-separator)
(set-macro-character +colon+ 'read-separator)
(loop
for key = (read-next-object +colon+ +right-brace+ stream)
while key
for value = (read-next-object +comma+ +right-brace+ stream)
collect `(cons ,key ,(transform-primitive value)) into pairs
finally (return `(create-json-hash-table ,@pairs)))))
Let’s test this:
> [true, false, null]
#(T NIL NIL)
While JSON requires that object keys be strict JSON strings (with surrounding double quotes, etc.), Javascript on the other hand doesn’t. Object keys in Javascript don’t need to be surrounded by double quotes.
When we try to use this syntax with our reader, we get an error.
> { foo: 1 }
; Evaluation aborted on #<UNBOUND-VARIABLE FOO {1003AC8E03}>.
A look at the generated sexp makes clear why we get the runtime thinks foo is unbound.
> (read)
;; Input: { foo: 1 }
(CREATE-JSON-HASH-TABLE (CONS FOO 1))
This is also easy to fix using the stringify-key function.
(defun stringify-key (key)
(etypecase key
(symbol (string-downcase (string key)))
(string key)))
(defun read-left-brace (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character +comma+ 'read-separator)
(set-macro-character +colon+ 'read-separator)
(loop
for key = (read-next-object +colon+ +right-brace+ stream)
while key
for value = (read-next-object +comma+ +right-brace+ stream)
collect `(cons ,(stringify-key key) ,(transform-primitive value)) into pairs
finally (return `(create-json-hash-table ,@pairs)))))
Some tests:
> { foo: 1 }
#<HASH-TABLE :TEST EQUAL :COUNT 1 {1004248763}>
> (read)
;; Input: { foo: 1 }
(JSON-READER::CREATE-JSON-HASH-TABLE (CONS "foo" 1))
One problem with read-left-brace is that, within its dymanic scope, it overrides the macro function for colon. The standard readtable in Lisp defines colon to be a package marker for symbols. What this means is that, when parsing a JSON object, we will face problems if a symbol contains a colon.
> { foo: cl:pi }
; Evaluation aborted on #<SIMPLE-ERROR "Unexpected next char: ~S" {10043B7083}>.
Again, this is not very hard to fix. I will leave that as an exercise to the reader.
Apart from creating new functions, we also directly change the current readtable when associating macro functions with characters:
(set-macro-character +left-bracket+ 'read-left-bracket)
(set-macro-character +right-bracket+ 'read-delimiter)
(set-macro-character +left-brace+ 'read-left-brace)
(set-macro-character +right-brace+ 'read-delimiter)
If we were to package the JSON reader in a library and add these lines as toplevel forms in the library’s source code, we would clobber the user’s current readtable when the library source was loaded. This is not desirable. What we want instead is to provide user with a hook to enable/disable JSON syntax at will.
So instead of adding these as toplevel forms, we could provide them inside a function:
(defun enable-json-syntax ()
(set-macro-character +left-bracket+ 'read-left-bracket)
(set-macro-character +right-bracket+ 'read-delimiter)
(set-macro-character +left-brace+ 'read-left-brace)
(set-macro-character +right-brace+ 'read-delimiter))
Now, when users want to enable JSON syntax from the REPL, they could simply call enable-json-syntax.
Enabling this syntax inside a source file is a bit trickier. Let’s assume we write our file like this:
;;; foo.lisp
(in-package #:foobar)
(enable-json-syntax)
(defun foobar ()
["foo", "bar"])
Consider what happens when this file is loaded using (load (compile-file "foo.lisp")). enable-json-syntax will only get called during LOAD. However, by then, it is too late.
Remember that reader macros only work at read-time i.e. when the reader is translating raw text into Lisp s-expressions. In the example above, the definition for foobar was translated from raw text to sexp during COMPILE-FILE and not LOAD. So what we really want is to run enable-json-syntax during COMPILE-FILE instead of LOAD. The simplest way to achieve this is to wrap the function call inside an EVAL-WHEN:
;;; foo.lisp
(in-package #:foobar)
(eval-when (:compile-toplevel :load-toplevel :execute)
(enable-json-syntax))
(defun foobar ()
["foo", "bar"])
EVAL-WHEN ensures that enable-json-syntax is called during COMPILE-FILE and LOAD, so you get sane behaviour with both (load (compile-file "foo.lisp")) and (load "foo.lisp").
However, this still suffers from two problems:
There is no way to undo this – we can’t provide a disable-json-syntax because we don’t keep track of the previous macro functions for these characters, if any.
This still clobbers the current readtable. It might not as be a big problem when a user calls this function directly on the REPL, however since the current readtable is passed as is during LOAD and COMPILE-FILE, any modifications to the readtable will persist globally even after these operations finish.
Both these problems are solved by making a slight modification to enable-json-syntax.
(defvar *previous-readtables* nil)
(defun enable-json-syntax ()
(push *readtable* *previous-readtables*)
(setq *readtable* (copy-readtable))
(set-macro-character +left-bracket+ 'read-left-bracket)
(set-macro-character +right-bracket+ 'read-delimiter)
(set-macro-character +left-brace+ 'read-left-brace)
(set-macro-character +right-brace+ 'read-delimiter))
We maintain a stack of previous readtables. When enable-json-syntax is called, the current readtable is pushed on the stack of previous readtables and a copy is made the current readtable. This ensures that subsequent modifications to the readtable are made on our copy and not the readtable that we inherited.
Now we can provide a simple way to disable JSON syntax.
(defun disable-json-syntax ()
(setq *readtable* (pop *previous-readtables*)))
Note: we must ensure that any call to enable-json-syntax is balanced with a subsequent call to disable-json-syntax. If we don’t, the stack of previous readtables will get corrupted.
This solves the first problem, but what about the second? Due to an interesting peculiarity of LOAD and COMPILE-FILE – both of these functions bind *READTABLE* to its current value before working on the file – (setq *readtable* (copy-readtable)) by itself is enough to ensure that modifications do not persist after these operations finish. In fact, if we only ever call enable-json-syntax and disable-json-syntax from source files and never from the REPL directly, we don’t need to manage the stack of previous readtables at all since dynamic binding takes care of this for us.
Finally, it might be a bit cumbersome for your users to write (eval-when (:compile-toplevel :load-toplevel ...)) all the time, so we could redefine these functions as macros.
(defmacro enable-json-syntax ()
'(eval-when (:compile-toplevel :load-toplevel :execute)
(push *readtable* *previous-readtables*)
(setq *readtable* (copy-readtable))
(set-macro-character +left-bracket+ 'read-left-bracket)
(set-macro-character +right-bracket+ 'read-delimiter)
(set-macro-character +left-brace+ 'read-left-brace)
(set-macro-character +right-brace+ 'read-delimiter)))
(defmacro disable-json-syntax ()
'(eval-when (:compile-toplevel :load-toplevel :execute)
(setq *readtable* (pop *previous-readtables*))))
Your users can now enable/disable JSON syntax at will using these two macros. As long as calls to enable-json-syntax and disable-json-syntax are balanced, this will work well both on the REPL and in a source file. For reference, here’s how a user source file might look with these definitions in place:
;;; foo.lisp
(in-package #:foobar)
(enable-json-syntax)
(defun foobar ()
["foo", "bar"])
;; Write more definitions
(disable-json-syntax)
It is worth mentioning Named-Readtables here. This is a library designed to make readtable management as easy as package management. If you are providing a custom reader syntax in your library, consider using Named-Readtables.
(Thanks to handle0174 and xach for suggestions)
Reader macros are a powerful way to expand Lisp’s syntax in new and wonderful ways. However with great power comes great responsibility, so you should learn to use them with great care. For example, while a JSON reader was a good exercise in understanding reader macros, I would never use it in real world for the simple reason that easier alternatives already exist. e.g. a plain list or even a vector literal:
'(1 2 3)
#(1 2 3)
Another disadvantage of inventing new syntax is that it doesn’t work well with existing development tools. e.g. JSON array and object syntax doesn’t work very well with lisp and paredit modes in Emacs – even simple operations like C-M-f and C-M-b (to go forward or backward sexp) don’t work very well.
There is a saying that goes along these lines: where a function will do, don’t use a macro. A corollary for reader macros could be: where a sexp will do, don’t use a reader macro. Yes, it might be a subjective call, but think twice before using a reader macro.
However, when done right, reader macros can work wonders. Take a look at cl-interpol [3], which adds support for string interpolation to Common Lisp, so you can easily embed newlines in strings or even create regexes more simply.
> #?"foo\nbar"
"foo
bar"
> #?/\bfoo\b/
"\\bfoo\\b"
A few other possible use cases for reader macros are:
(Thanks to lispm)
Source code used in this post is available in a json-reader.lisp. A battery of tests is also provided.
I have not covered how READ handles whitespace following the Lisp expression. When you provide 'foo as input on the standard input, you need to follow it up with the a newline character. READ will read past the newline character in this case; so the stream position after single-quote-reader will actually go past the newline
Actually, comma is already defined in the standard readtable as a terminating macro character – it is a part of the backquote syntax. So technically, we could have done without associating comma with read-separator.
Technically, cl-interpol doesn’t define a new reader macro, it installs ? (question mark) as a “sub character” of the standard dispatching macro character # (sharpsign). Dispatching macro characters are a special class of reader macros which allow you to “make the most of the ASCII character set; one can only have so many one-character read-macros.” (On Lisp, Chapter 17, Read-Macros)
Common Lisp’s condition system, with its exceptions and restarts, is one of its unique features. Unfortunately, there aren’t many good tutorials explaining this concept very well. One good introduction to this is the chapter on conditions and restarts in Peter Seibel’s excellent book, Practical Common Lisp. This tutorial assumes some knowledge of the condition system, so you might want to read that chapter before proceeding. Another good read is Kent Pitman’s paper, Condition Handling in the Lisp Language Family.
I’ll attempt to show how effective CL’s condition system can be, with a validator for CSV (comma-separated values) files. The validator will check that all the fields in each row of the file are valid (according to some defined criteria).
The first row of the CSV will be a comma-separated list of headers, followed by rows with each column corresponding to the headers in the first row. A sample file looks like this:
rating,url,visitors,date
4,http://chaitanyagupta.com/home,1233445,2000-01-01
5,http://chaitanyagupta.com/blog,33333,2006-02-02
5,http://chaitanyagupta.com/code,2121212,2007-03-03
First we write functions to validate fields for the four headers we used above: rating, url, visitors, and date. Note that these functions depend on CL-PPCRE.
(defun validate-url (string)
"The URL of the page; should start with http:// or https://."
(unless (cl-ppcre:scan "^https?://" string)
(csv-error "URL invalid." :value string)))
(defun validate-rating (string)
"String should contain an integer between 1 and 5, inclusive."
(let ((rating (parse-integer string :junk-allowed t)))
(unless (and (integerp rating) (<= 1 rating 5))
(csv-error "Rating not an integer in range." :value string))))
(defun validate-visitors (string)
"The number of visitors to the page; string should contain an
integer more than or equal to zero."
(let ((visitors (parse-integer string :junk-allowed nil)))
(unless (and (integerp visitors) (>= visitors 0))
(csv-error "Number of visitors invalid." :value string))))
(defun validate-date (string)
"The published date of the URL. Should be in yyyy-mm-dd format."
(let ((split (cl-ppcre:split "-" string)))
(flet ((valid-number-of-digits-p (string n)
(and (every #'digit-char-p string)
(= (length string) n))))
(unless (and (valid-number-of-digits-p (first split) 4)
(valid-number-of-digits-p (second split) 2)
(valid-number-of-digits-p (third split) 2))
(csv-error "Published date not in valid format." :value string)))))
All these functions take a string as an argument, and if it doesn’t satisfy the validation criteria, an error is signalled using the function csv-error. This is defined next.
The function csv-error signals a condition of type csv-error, both of which are defined below.
(define-condition csv-error (error)
((message
:initarg :message
:accessor csv-error-message
:initform nil
:documentation "Text message indicating what went wrong with the validation.")
(value
:initarg :value
:accessor csv-error-value
:initform nil
:documentation "The value of the field for which the error is signalled.")
(line-number
:initarg :line-number
:accessor csv-error-line-number
:initform nil
:documentation "The line number of the row in for the error was signalled.")))
;; Do something more useful than the default printer behaviour
(defmethod print-object ((object csv-error) stream)
(print-unreadable-object (object stream :type t :identity t)
(format stream "~@[L~A ~]~S~@[: ~S~]"
(csv-error-line-number object)
(csv-error-message object)
(csv-error-value object))))
;; We use this function to signal our validation error
(defun csv-error (message &key value line-number)
(error 'csv-error
:message message
:value value
:line-number line-number))
The parser converts raw CSV text into a list of lists – each item in these lists corresponds to a field in the CSV.
(defun parse-csv-file (file)
(with-open-file (f file :direction :input)
(loop
for line = (read-line f nil)
while line
collect (cl-ppcre:split "," line))))
Finally, we get down to writing the validator, validate-csv. If the validation is succesful (i.e. all the fields in the CSV are valid), the function returns normally. If any invalid field is present, an error will be signalled (using the validator functions defined above).
This version of the validator doesn’t contain any restarts though.
(defun validate-csv (file)
(destructuring-bind (headers . rows)
(parse-csv-file file)
(loop
for row in rows
for line-number upfrom 2
do
(when (/= (length row) (length headers))
(csv-error "Number of fields doesn't equal number of headers."
:line-number line-number))
(handler-bind
;; Set the LINE-NUMBER slot of the signalled
;; csv-error. Note that since this clause returns normally,
;; the error doesn't stop here, it goes "up" the stack
((csv-error #'(lambda (c)
(setf (csv-error-line-number c) line-number))))
(loop
for header in headers
for field in row
do (validate-field header field))))))
;; Takes a header name and a string value as arguments; checks the
;; validity of the value by calling the appropriate validator function
(defun validate-field (header value)
(flet ((header-matches (string)
(string-equal header string)))
(cond
((header-matches "url") (validate-url value))
((header-matches "rating") (validate-rating value))
((header-matches "visitors") (validate-visitors value))
((header-matches "date") (validate-date value))
(t (csv-error "Invalid header." :value header)))))
There are a few actions we can take once an “invalid” field has been detected (i.e. a csv-error is signalled), e.g. we can abort the validation, we can continue validation on the next row, or we continue validation with the remaining fields in the same row (to name just a few).
Aborting the validation is as simple as invoking the ABORT restart in the debugger, or doing something like this:
(handler-case (progn
(validate-csv "~/tmp/test.csv")
:success)
(csv-error () :failure))
To continue validation on the same row, or the next one, we add a couple of restarts using the with-simple-restart macro:
(defun validate-csv (file)
(destructuring-bind (headers . rows)
(parse-csv-file file)
(loop
for row in rows
for line-number upfrom 2
do
;; If this restart is invoked, validation will continue on
;; the next row
(with-simple-restart (continue-next-row "Continue validation on next row.")
(when (/= (length row) (length headers))
(csv-error "Number of fields doesn't equal number of headers."
:line-number line-number))
(loop
for header in headers
for field in row
do
(handler-bind
((csv-error #'(lambda (c)
(setf (csv-error-line-number c) line-number))))
;; If this restart is invoked, validation will continue
;; on the next field in the row
(with-simple-restart (continue-next-field "Continue validation on next field.")
(validate-field header field))))))))
Time for some fun now. Pass an invalid file to the validator, and what do we see in the debugger? Two new restarts: CONTINUE-NEXT-FIELD, and CONTINUE-NEXT-ROW. Select any one of them to see the validation move forward. The ABORT restart should be present all the time, so we can end the validation any time we want.
We’ll add one more restart now: this will allow us to revalidate the whole file if an error is signalled.
;; Note that what was known as VALIDATE-CSV earlier is now called
;; VALIDATE-CSV-AUX.
(defun validate-csv (file)
(restart-case (validate-csv-aux file)
(retry-file ()
:report (lambda (stream)
(format stream "Retry validating the file ~A." file))
(validate-csv file))))
(defun validate-csv-aux (file)
(destructuring-bind (headers . rows)
(parse-csv-file file)
(loop
for row in rows
for line-number upfrom 2
do
(with-simple-restart (continue-next-row "Continue validation on next row.")
(when (/= (length row) (length headers))
(csv-error "Number of fields doesn't equal number of headers."
:line-number line-number))
(loop
for header in headers
for field in row
do
(handler-bind
((csv-error #'(lambda (c)
(setf (csv-error-line-number c) line-number))))
(with-simple-restart (continue-next-field "Continue validation on next field.")
(validate-field header field))))))))
Now what happens if we pass an invalid file to validate-csv? We get the RETRY-FILE restart in the debugger. This means that we can fix the problematic field, save the file, and start the validation all over again, without having exited the debugger!
Apart from the debugger, we can also handle restarts using handler-bind and find-restart.
For example, the following function will continue validating the file as long as CSV-ERRORs are signalled and one of CONTINUE-NEXT-FIELD or CONTINUE-NEXT-ROW restarts is available. It collects those errors in a list and returns the same.
(defun list-csv-errors (file)
(let ((result nil))
(handler-bind
((csv-error #'(lambda (c)
(let ((restart (or (find-restart 'continue-next-field)
(find-restart 'continue-next-row))))
(when restart
(push c result)
(invoke-restart restart))))))
(validate-csv file))
(nreverse result)))
If we want a non-programmer to use the validator, we can provide a way to upload the CSV file (e.g. using Hunchentoot) and give a nicely formatted output of list-csv-errors in the browser.
What I really like about the condition system is how it allows one to defer decisions to higher-level functions. The low-level functions provide different ways to move forward in case of exceptions (this is what validate-csv does), while the higher-level functions actually get to decide what path to take (like list-csv-errors).
If we wanted list-csv-errors to list only one error per each row, that change would have been trivial, thanks to the restarts we have provided. This separation of logic, IMHO, makes it a very elegant tool in dealing with problems like these.