An example of macros in Common Lisp

lengths_dsl.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Lengths DSL API
;;
;; Currently supported features:
;; - Metric (m, cm, mm) and English (ft, in) units
;; - Seamless sum of mixed units: (u% (+ 1m 1ft 1in))
;; - Explicit conversion to a desired target unit: (u% (+ 1m 1ft) in :cm)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(ql:quickload "parse-float")
(ql:quickload "cl-ppcre")
(ql:quickload "trivia")

;; We use `destructuring-bind' quite a bit in this implementation, but it's a bit
;; of a mouthful, hence this alias:
(setf (macro-function 'dbind) (macro-function 'destructuring-bind))

;; Common Lisp is more lenient in the symbols one can use to create identifiers,
;; so u% is just an arbitrary choice for an identifier that signals our intent
;; to "drop" into the Lengths DSL and evaluate as usual.
;;
;; (u% (+ 1m 1ft) in :cm)
;;
;; expands to:
;; (convert-to-unit (meters 1.3048) :cm)
;;
;; evaluates to:
;; (130.48001 . :CM)
;;
;; Beware that this cons-cell representation is an implementation detail, so even
;; when the code expands to a constant quantity, the resulting expression is a
;; constructor:
;;
;; (u% (+ 1m 2m))
;;
;; expands to:
;; (meters 3.0)
;;
;; The DSL can be used seamlessly with other regular Common Lisp expressions:
;;
;; (let ((x (read-length)))
;;   (u% (+ x 1m 2m)))
;;
;; expands to:
;; (let ((x (read-length)))
;;   (convert-to-unit (sum-lengths (meters 3.0) x) :m))

;; However, constant folding only happens in a bottom-up fashion (i.e., from the
;; leaves of the AST to the top). For example, the following expression could
;; theoretically be reduced to a single constant, but this implementation doens't
;; yet support it:
;;
;; (u% (let ((x 1m))
;;   (+ x 1m 2m)))
;;
;; expands to:
;; (convert-to-unit
;;  (let ((x (meters 1.0)))
;;    (sum-lengths x (meters 1.0) (meters 2.0)))
;;  :m)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Entry Point
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro u% (expression &optional (in :in) (target-unit :m))
  (unless (valid-unit-p target-unit)
    (error "~a is not a valid length unit." target-unit))
  (unless (member in '(in :in))
    (error "Expected `in` keyword after expression; got: ~a" in))
  (let ((result (parse-dsl expression))
        (target-unit (ensure-keyword target-unit)))
    (if (and (length-constant-p result) (eq target-unit :m))
        result
        `(convert-to-unit ,result ,target-unit))))

(defun ensure-keyword (thing)
  (cond ((stringp thing) (to-keyword thing))
        ((symbolp thing) (to-keyword (symbol-name thing)))
        (t (error "Cannot convert ~a to a keyword" thing))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun parse-dsl (expression)
  (let ((result (rest (try-parse-dsl expression))))
    (fold-constants result)))

(defun try-parse-dsl (expression)
  (cond ((symbolp expression)
         (try-parse-constant expression))
        ;; a string, integer, float, ..., i.e., a primitive
        ((not (consp expression))
         (mark-as-untouched expression))
        ((symbolp (first expression))
         (try-parse-operation expression))
        ;; try and see if there are parseable symbols deeper in the tree
        (t (try-parse-list expression))))

(defun try-parse-list (expression)
  (let* ((parsed-items (mapcar #'try-parse-dsl expression))
         (raw-args (mapcar #'cdr parsed-items)))
    (if (every #'untouched-p parsed-items)
        (mark-as-untouched expression)
        (mark-as-parsed `,raw-args))))

(defun try-parse-constant (symbol)
  (dbind (amount . unit) (try-parse-unit (symbol-name symbol))
    (mark-as-parsed
     (case unit
       ((:m) `(meters ,amount))
       ((:cm) `(meters ,(convert-amount amount :cm :m)))
       ((:mm) `(meters ,(convert-amount amount :mm :m)))
       ((:ft) `(feet ,amount))
       ((:in) `(feet ,(convert-amount amount :in :ft)))
       (otherwise (mark-as-untouched symbol))))))

(defun try-parse-operation (expression)
  (dbind (operator . args) expression
    (dbind (&whole whole parsed . parsed-args) (try-parse-list args)
      (if parsed
          (mark-as-parsed `(,(to-lengths-operator operator) ,@parsed-args))
          whole))))

(defun to-lengths-operator (operator)
  (case operator
    ((+) 'sum-lengths)
    (otherwise operator)))

(defun try-parse-unit (string)
  (let ((amount-and-unit (match-quantity-regex string)))
    (if amount-and-unit
        (let ((amount (aref amount-and-unit 0))
              (unit (aref amount-and-unit 1)))
          (cons (parse-number amount)
                (to-keyword unit)))
        (cons nil nil))))

(defun parse-number (number)
  (if (every #'digit-char-p number)
      (parse-integer number)
      (parse-float:parse-float number)))

(defun match-quantity-regex (string)
  ;; the first value returns the whole match; the second value
  ;; returns the captured groups in the regular expression
  (nth-value 1 (cl-ppcre:scan-to-strings
                "((?:\\d*[.])?\\d+)([a-zA-Z]+)" string)))

;; We need to mark expressions as either parsed or untouched to know when we
;; should map math operators like `+' to their equivalent (`sum-lengths')
(defun mark-as-parsed (expression)
  (if (marked-p expression)
      expression
      (cons t expression)))

(defun mark-as-untouched (expression)
  (if (marked-p expression)
      expression
      (cons nil expression)))

(defun marked-p (expression)
  (and (consp expression)
       (or (eq t (car expression))
           (eq nil (car expression)))))

(defun untouched-p (expression)
  (null (car expression)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Object Model
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *length-units-metric-system*
  '(m :m cm :cm mm :mm))

(defparameter *length-units-english-system*
  '(ft :ft in :in))

(defparameter *length-units*
  (append *length-units-metric-system*
          *length-units-english-system*))

;;-----------------------------------------------------------------------------
;; Quantity Representation -- cons cells is the simplest representation
;;-----------------------------------------------------------------------------
(setf (fdefinition 'make-quantity) #'cons)
(setf (fdefinition 'amount-for) #'car)
(setf (fdefinition 'unit-for) #'cdr)

(defun meters (amount)
  (make-quantity amount :m))

(defun feet (amount)
  (make-quantity amount :ft))

(defun length-p (thing)
  (and (consp thing)
       (numberp (amount-for thing))
       (valid-unit-p (unit-for thing))))

(defun valid-unit-p (unit)
  (not (null (member unit *length-units*))))

(defun compatible-units-p (unit-a unit-b)
  (eq (to-standard-unit unit-a)
      (to-standard-unit unit-b)))

(defun length== (a b)
  (and (= (amount-for a) (amount-for b))
       (eq (unit-for a) (unit-for b))))

(defun to-standard-unit (unit)
  (cond ((member unit *length-units*) :m)
        (t (error "Unit ~a isn't known" unit))))

;;-----------------------------------------------------------------------------
;; Conversion between Units
;;-----------------------------------------------------------------------------

;; We only need to store conversion factors from/to the reference unit
;; (i.e., the metric system)
(defparameter *length-units-conversion-table*
  '(("m-m" . 1)
    ("m-cm" . 100)
    ("m-mm" . 1000)
    ("m-ft" . 3.28084)
    ("m-in" . 39.37008)
    ("in-m" . 0.0254)
    ("ft-m" . 0.3048)
    ("mm-m" . 0.001)
    ("cm-m" . 0.01)))

(defun convert-to-unit (quantity target-unit)
  (let ((unit (unit-for quantity)))
    (if (not (compatible-units-p unit target-unit))
        (error "~a and ~a are not compatible units" unit target-unit))
    (make-quantity (convert-amount (amount-for quantity) unit target-unit)
                   target-unit)))

(defun convert-amount (amount source-unit destination-unit)
  (if (can-convert-directly-p source-unit destination-unit)
      (convert-amount-directly amount source-unit destination-unit)
      (let ((standard (to-standard-unit source-unit)))
        (convert-amount (convert-amount amount source-unit standard)
                        standard
                        destination-unit))))

(defun convert-amount-directly (amount source-unit destination-unit)
  (let* ((key (format nil "~a-~a" source-unit destination-unit))
         (conversion-factor (get-conversion-factor key)))
    (if (not (null conversion-factor))
        (* amount (cdr conversion-factor))
        (error "Cannot find direct conversion information for: ~a" key))))

(defun can-convert-directly-p (source-unit destination-unit)
  (let* ((key (format nil "~a-~a" source-unit destination-unit)))
    (not (null (get-conversion-factor key)))))

(defun get-conversion-factor (key)
  (assoc key *length-units-conversion-table* :test #'string-equal))

;;-----------------------------------------------------------------------------
;; Operations
;;-----------------------------------------------------------------------------
(defun normalize-length (length)
  (meters (convert-amount (amount-for length) (unit-for length) :m)))

(defun sum-lengths (&rest lengths)
  (let ((normalized (mapcar #'normalize-length lengths)))
    (reduce #'add-normalized-lengths normalized)))

(defun add-normalized-lengths (a b)
  (assert (eq (unit-for a) (unit-for b)))
  (assert (eq (unit-for a) :m))
  (meters (+ (amount-for a)
             (amount-for b))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Optimizations: Constant Folding (i.e., reduction of constant operations)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun fold-constants (parsed-expression)
  (cond ((length-constant-p parsed-expression)
         parsed-expression)
        ;; We only attempt to completely fold the expression when
        ;; dealing with length operators...
        ((length-operation-p parsed-expression)
         (dbind (operator . args) parsed-expression
           (let* ((parsed-args (mapcar #'fold-constants args))
                  (result-args (fold-length-args operator parsed-args)))
             (if (= (length result-args) 1)
                 `,(first result-args)
                 `(,operator ,@result-args)))))
        ;; Though we do recursively fold all subexpressions
        ((consp parsed-expression)
         `,(mapcar #'fold-constants parsed-expression))
        ;; Primitives like numbers, strings, etc., are left untouched
        (t parsed-expression)))

(defun fold-length-args (operator args)
  (multiple-value-bind (foldable-args other-args)
      (partition-by #'length-constant-p args)
    (case operator
      ((sum-lengths)
       (let ((folded-quantity (apply #'sum-lengths (mapcar #'try-eval foldable-args))))
         `(,(to-length-constant folded-quantity)
           ,@other-args))))))

(defun to-length-constant (quantity)
  (assert (length-p quantity))
  `(meters ,(amount-for quantity)))

(defun length-constant-p (expression)
  (trivia:match expression
    ((list (or 'meters 'feet)
           (trivia:guard value (numberp (try-eval value))))
     t)))

(defun length-operation-p (expression)
  (trivia:match expression
    ((list* 'sum-lengths _) t)))

(defun try-eval (expression)
  (ignore-errors
   (eval expression)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General Utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun to-keyword (string)
  (if string
      (values (intern (string-upcase string) :keyword))))

(defun partition-by (predicate list)
  (loop for item in list
        if (funcall predicate item) collect item into yes
          else collect item into no
        finally (return (values yes no))))