Explanation of macros; Haskell macros

[Coby Beck]

<mike420 at ziplip.com> wrote in message
news:GGDUFQOGIAD5H2L3GDEKNREOMFKFLREPEFD3MGCP at ziplip.com...
> I think others dropped the ball while trying to explain macros
> to non-Lispers recently. The examples I saw posted were either
> too difficult or easily doable without macros (maybe even easier).

Here's a nice example from some production code I wrote that is easy to
grok.

The purpose: a socket server excepts a set of specific commands from
clients.  Client commands must be verified as allowed and the arguments
marshalled before applying the appropriate function to the arguments.  I
wanted a clean way to express this and automate the writing of error
catching code.

Usage: define-server-cmd name (method-parameters) constraints code

Sample usage:
(define-server-cmd set-field-sequence ((session morph-configuration-session)
field-list)
    ((listp field-list)
     (remove-if-not #'(lambda (key) (member key *logical-types*))
field-list))
  (with-slots (client source-blueprint state) session
    (setf (field-sequence (source-blueprint session)) field-list)
    (setf state :blueprint-set)
    (send session (write-to-string state))))

The resulting expansion:
(PROGN
  (DEFMETHOD SET-FIELD-SEQUENCE
    ((SESSION MORPH-CONFIGURATION-SESSION) FIELD-LIST)
    (WITH-SLOTS (CLIENT SOURCE-BLUEPRINT STATE)
                SESSION
      (SETF (FIELD-SEQUENCE (SOURCE-BLUEPRINT SESSION))
            FIELD-LIST)
      (SETF STATE :BLUEPRINT-SET)
      (SEND SESSION (WRITE-TO-STRING STATE))))
  (DEFMETHOD MARSHAL-ARGS-FOR-CMD
    ((CMD (EQL 'SET-FIELD-SEQUENCE))
     (SESSION MORPH-CONFIGURATION-SESSION))
    (LET (FIELD-LIST)
      (PROGN
        (SETF FIELD-LIST
              (RECEIVE SESSION :TIMEOUT *COMMAND-PARAMETER-TIMEOUT*))
        (UNLESS FIELD-LIST
          (ERROR 'TIMEOUT-ERROR
                 :EXPECTATION
                 (FORMAT NIL "~A parameter to ~A command" 'FIELD-LIST CMD)
                 :TIMEOUT
                 *COMMAND-PARAMETER-TIMEOUT*)))
      (UNLESS (LISTP FIELD-LIST)
        (ERROR 'COMMAND-CONSTRAINT-VIOLATION
               :CONSTRAINT
               '(LISTP FIELD-LIST)
               :COMMAND
               CMD))
      (UNLESS (REMOVE-IF-NOT #'(LAMBDA (KEY)
                                 (MEMBER KEY *LOGICAL-TYPES*))
                             FIELD-LIST)
        (ERROR 'COMMAND-CONSTRAINT-VIOLATION
               :CONSTRAINT
               '(REMOVE-IF-NOT #'(LAMBDA (KEY)
                                   (MEMBER KEY *LOGICAL-TYPES*))
                               FIELD-LIST)
               :COMMAND
               CMD))
      (LIST FIELD-LIST)))
  (PUSHNEW 'SET-FIELD-SEQUENCE *CONFIG-SERVER-COMMANDS*))

Usage of what the macro gave me in context (some error handling noise
removed):

(defmethod run-config-command-loop ((session morph-configuration-session))
  (let ((*package* (find-package :udt)))
  (unwind-protect
      (with-slots (client) session
        (loop
         (let (cmd)
           (setf cmd (receive session :timeout *command-timeout* :eof-value
:eof))
               (cond
                ((or (eq cmd :eof) (eq cmd :stop)) (return))
                ((member cmd *config-server-commands*)
                 (let ((cmd-args (marshal-args-for-cmd cmd session)))
                   (apply cmd session cmd-args)))
                (t (execute-generic-command cmd client)))))

        (send session "session loop terminated"))
    (when (eq (state session) :finalized)
        (setf *active-sessions* (delete session *active-sessions*))))))

The macro definition:

(defmacro define-server-cmd (name (session-specializer &rest args)
     constraints &body body)
  (let ((session-var (car session-specializer))
        (session-class (cadr session-specializer)))
    `(progn
       (defmethod ,name ((,session-var ,session-class)
          ,@(mapcar #'(lambda (arg)
   (if (symbolp arg) arg (car arg)))
      args))
  , at body)
       (defmethod marshal-args-for-cmd
           ((cmd (eql ',name)) ,session-specializer)
         (let (, at args)
           ,@(loop for var in args
                   collect
     `(progn
        (setf ,var (receive ,session-var
       :timeout *command-parameter-timeout*))
        (unless ,var
   (error 'timeout-error
          :expectation (format nil "~A parameter to ~A command"
                               ',var cmd)
          :timeout *command-parameter-timeout*))))
           ,@(loop for con in constraints
                   collect
     `(unless ,con
        (error 'command-constraint-violation
        :constraint ',con
        :command cmd)))
           (list , at args)))
       (pushnew ',name *config-server-commands*))))

I think the advantages are tremendously obvious, and very satisfying to take
advantage of!

-- 
Coby Beck
(remove #\Space "coby 101 @ big pond . com")