;; Copyright (c) Marijn Haverbeke, marijnh@gmail.com

;; This software is provided 'as-is', without any express or implied
;; warranty. In no event will the authors be held liable for any
;; damages arising from the use of this software.
;;
;; Permission is granted to anyone to use this software for any
;; purpose, including commercial applications, and to alter it and
;; redistribute it freely, subject to the following restrictions:
;;
;; 1. The origin of this software must not be misrepresented; you must
;;    not claim that you wrote the original software. If you use this
;;    software in a product, an acknowledgment in the product
;;    documentation would be appreciated but is not required.
;;
;; 2. Altered source versions must be plainly marked as such, and must
;;    not be misrepresented as being the original software.
;;
;; 3. This notice may not be removed or altered from any source
;;    distribution.

;; Struct-based variant types in Common Lisp.

(defpackage :variant
  (:use :cl)
  (:export #:variant #:vcase #:evcase #:vbind))

(in-package :variant)

(defmacro variant (name &body constructors)
  (multiple-value-bind (name slots) (if (consp name) (values (car name) (cdr name)) (values name nil))
    `(progn
       (defstruct (,name (:copier nil) (:constructor nil)) ,@slots)
       ,@(loop :for c :in constructors
               :collect (multiple-value-bind (name* fields)
                            (if (consp c) (values (car c) (cdr c)) (values c nil))
                          `(defstruct (,name* (:include ,name)
                                              (:copier nil) (:predicate nil)
                                              (:constructor ,name* ,fields))
                             ,@fields)))
       ',name)))

(defun acc (struct slot place)
  `(,(intern (format nil "~a-~a" struct slot) (symbol-package struct)) ,place))

(defun case-body (sym cases)
  (loop :for (match . body) :in cases
        :if (not (consp match)) :collect `(,match ,@body)
        :else :collect
        `(,(car match)
           (let ,(loop :for slot :in (cdr match)
                       :collect (multiple-value-bind (var name)
                                    (if (consp slot) (values (car slot) (cadr slot)) (values slot slot))
                                  `(,var ,(acc (car match) name sym))))
             ,@body))))

(defun make-case (case value cases)
  (let ((v (gensym)))
    `(let ((,v ,value))
       (,case ,v ,@(case-body v cases)))))

(defmacro vcase (value &body cases)
  (make-case 'typecase value cases))
(defmacro evcase (value &body cases)
  (make-case 'etypecase value cases))
(defmacro vbind ((type &rest slots) value &body body)
  (make-case 'etypecase value (list (cons (cons type slots) body))))