;;;; def.lisp

(in-package #:def)

(defmacro var (name &key doc (init nil initp))
  "DEFVAR with optional documentation and optional initform. Lets you
easily document uninitialized special variables."
  (assert (good-muffed-var-name-p name) (name)
          "Special variable ~s is not wearing earmuffs :(")
  `(progn
     (defvar ,name)
     ,@(when initp
         (list `(setf ,name ,init)))
     ,@(when doc
         (list `(setf (documentation ',name 'cl:variable) ,doc)))))

(defmacro const (name value &optional doc)
  "Define a constant in a way that is redefinable whenever the form is
reevaluated."
  (assert (good-muffed-var-name-p name :muffer "+"))
  (let ((newval (gensym "NEWVAL-")))
   `(let ((,newval ,value))
      (handler-bind ((error
                       (lambda (&rest ignore)
                         (declare (ignore ignore))
                         (invoke-restart 'cl:continue))))
        (makunbound ',name))
      (defconstant ,name ,newval ,@(when doc (list doc))))))

(defmacro class (name (&rest supers) &body slots-and-options)
  "Define a class. 

SLOTS-AND-OPTIONS := (SLOT-SPEC1 ... SLOT-SPECN . CLASS-OPTIONS)

Each SLOT-SPEC is a list of SLOT-NAME-SPECs followed by keyword slot
options, E.g:

(X Y Z :type real :initform 0)

Would expand into three slot definitions 
(X :accessor X :initarg :X :type real :initform 0)
(Y :accessor Y :initarg :Y :type real :initform 0)
(Z :accessor Z :initarg :Z :type real :initform 0)

A SLOT-NAME-SPEC is either a symbol or a pair (NAME DOCSTRING). So the
above might have been written:

((X \"x coordinate\")
 (Y \"y coordinate\")
 (z \"z coordinate\")
 :type real :initform 0)

Which would have expanded the same way, but with documentation on each
slot definition.

There are a few flag style slot definition arguments. Flags do not
have an value after them, all flags must come before other options. Flags are:
  :prefix - prefix the accessor by the class name
  :ro     - only define a reader 
  :wo     - only define a writer 
  :noarg  - means no initarg

By default an accessor is defined.

CLASS-OPTIONS is a PLIST of class options.

E.g.

(def:class pt (thing)
  (x y z :prefix :type real :initform 0) 
  (label :type :string)
"
  (labels
      ((make-accessor-name (slot &optional prefix?)
         (if prefix?
             (intern (format nil "~a-~a" name slot))
             slot))
       (singlep (x)
         (find x '(:prefix :ro :wo :noarg) :test #'eq))
       (parse-slot-spec-expr (expr)
         " (names ... &key kwargs)"
         (multiple-value-bind (slot-names kwargs) (take-until #'keywordp expr)
           (multiple-value-bind (singles kwargs) (partition #'singlep kwargs)
             (let ((prefix-accessor? (find ':prefix singles :test #'eq))
                   (read-only? (find ':ro singles :test #'eq))
                   (write-only? (find ':wo singles :test #'eq))
                   (no-arg? (find ':noarg singles :test #'eq)))
               (assert (not (and read-only? write-only?)) ()
                       "A slot cannot be both read-only (:ro) and write-only (:wo).")
               (loop
                 :with accessor-type := (cond (read-only? :reader)
                                              (write-only? :writer)
                                              (t :accessor))
                 :for slot :in slot-names
                 :if (listp slot)
                   :collect
                   (destructuring-bind (slot doc) slot
                     (check-type doc string "a string")
                     `(,slot
                       ,accessor-type ,(make-accessor-name slot prefix-accessor?)
                       ,@(unless no-arg?
                           (list :initarg (alexandria:make-keyword slot)))
                       ,@kwargs
                       :documentation ,doc))
                 :else 
                   :collect
                 `(,slot
                   ,accessor-type ,(make-accessor-name slot prefix-accessor?)
                   ,@(unless no-arg?
                       (list :initarg (alexandria:make-keyword slot)))
                   ,@kwargs))))))

       (parse-class-options (kwargs)
         (loop :for (key val . more) :on kwargs :by #'cddr
               :if (listp val)
                 :collect (cons key val)
               :else 
                 :collect (list key val))))

    (let* ((slot-defs (loop :for expr :in slots-and-options
                            :while (listp expr)
                            :append (parse-slot-spec-expr expr)))
           (options (parse-class-options
                     (nth-value 1 (take-until #'keywordp slots-and-options)))))

      `(defclass ,name ,supers
         (,@slot-defs)
         ,@options))))


(defmacro fast (name (&rest lambda-list) -> return-type &body body)
  "A fastfun is one for which every parameter is typed, a return type is
declared. DEF:FAST generates an optimized DEFUN.

Each positional parameter must be a list (VAR TYPE) &KEY &REST and
&OPTIONAL arguments all look like (VAR TYPE . MORE) where MORE is
whatever defun normally accepts in the lambda list for these
arguments.

E.g. 

(def::fast sum-ints ((x integer) (y integer) &optional (z integer 0)) -> integer
    \"Sums integers\"
    (+ x y z))
"
  (assert (string-equal -> "->") () "-> must be named -> ** chortle **.")
  (multiple-value-bind (lambda-list type-declarations)
      (loop
        :with types := nil
        :with ll := nil
        :for x :in lambda-list
        :do (cond ((lambda-opt-p x)
                   (push x ll))
                  ((listp x)
                   (destructuring-bind (var type . other) x
                     (let ((found (find type types
                                        :test #'equalp
                                        :key #'second)))
                       (if found
                           (push var (cddr found))
                           (push (list 'cl:type type var) types)))
                     (push 
                      (if other (cons var other) var)
                      ll))))
        :finally (return (values (nreverse ll) types)))
    (let ((docstring (when (stringp (first body)) (first body)))) 
      `(defun ,name ,lambda-list
         ,@(when docstring (list docstring))
         (declare ,@type-declarations
                  (values ,return-type)
                  (optimize (speed 3) (safety 0)))
         ,@(if docstring (rest body) body)))))