;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: Using anonymous classes as type specifiers
;;   Created: 2025-02-26
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;;  (c) copyright 2025 by Gilbert Baumann

;;  Permission is hereby granted, free of charge, to any person obtaining
;;  a copy of this software and associated documentation files (the
;;  "Software"), to deal in the Software without restriction, including
;;  without limitation the rights to use, copy, modify, merge, publish,
;;  distribute, sublicense, and/or sell copies of the Software, and to
;;  permit persons to whom the Software is furnished to do so, subject to
;;  the following conditions:
;; 
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.


;;;; -- Overview ------------------------------------------------------------------------------

;; What we essentially want to have is types with parameters. We want that for
;; noffi, so that C types can map to Common Lisp types. We cannot somehow
;; define those classes beforehand because the user is able to make as many
;; derived typed as he wishes. Easiest is to just keep making pointer types.
;; Those classes come into existence the moment they appear (deep inside) some
;; form. Or made at runtime.

;; In ANSI-CL a class object is a perfectly fine type specifier. You can say:

;;     (DECLARE (TYPE #.(FIND-CLASS ...) X))

;; So the idea is to just have anonymous classes corresponding to things like
;; (POINTER <something>).

;; This file tries to figure out how and whether Common Lisp implementation
;; actually support it.

;; tl;dr Again, it's SBCL which cannot do that. With SBCL we must actually
;; name our classes and come up with funny symbol names that break the moment
;; you rename or delete packages.

;; For lack of any better name, we say we have HUH classes, a different kind
;; of classes that are anonymous (wrt FIND-CLASS). There is a INTERN-HUH-CLASS
;; which given a name that can about any Lisp object either finds that class
;; or interns it creating a new HUH-CLASS.

;; There is a type expander HUH defined which returns such a class. So you
;; can say:

;; (defun foo (x)
;;   (declare (type (huh (pointer (pointer char))) x))
;;   ...)

;; The idea here is that in the context of noffi in the end of day should be
;; able to say (DECLARE (#_<char**> argv) (#_<int> argc)) e.g.


;;;; -- The Fun -------------------------------------------------------------------------------

#+SBCL
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :sb-cltl2))

(defpackage :huh
  (:use :cl
        ;; MOP
        #+SBCL :SB-MOP
        #+CCL :CCL
        #+EXCL :MOP
        #+LISPWORKS :HCL
        #+ABCL :MOP
        #+ECL :CLOS
        #+CMU :PCL
        ;; CLtL2
        ;; CCL has it in CCL as well
        ;; LW has it in HCL too.
        #+SBCL :SB-CLTL2
        #+EXCL :SYS))

(in-package :huh)

(eval-when (:compile-toplevel :load-toplevel :execute)

  ;; We define our own kind of classes called a HUH-CLASS. We have our own
  ;; namespace for them (they are not registered with FIND-CLASS and thus
  ;; anonymous).

  (defclass huh-class (standard-class)
    ((huh-name :initarg :huh-name :reader huh-name)))

  (defmethod validate-superclass ((class huh-class) (superclass standard-class))
    t)

  ;; The only reason why our new classes are not standard classes is to be able
  ;; to have a MAKE-LOAD-FORM. (Without piling a gazillion EQL methods up).
  
  (defmethod make-load-form ((object huh-class) &optional env)
    (declare (ignore env))
    `(intern-huh-class ',(huh-name object)))

  #-SBCL
  (progn

    ;; Common Lisp is fine with anonymous classes. They are anonymous insofar as
    ;; FIND-CLASS doesn't know about them. We still would need some means to find
    ;; them though, but: The name does not need to be a symbol and does not need
    ;; to be known beforehand.

    (defvar *huh-hash*
      (make-hash-table :test 'equal))

    (defun intern-huh-class (name &optional env)
      (declare (ignore env))
      (or (gethash name *huh-hash*)
          (setf (gethash name *huh-hash*)
                (make-instance 'huh-class
                               :name `(huh ,name)
                               :direct-superclasses (list (find-class 'standard-object))
                               :huh-name name))))

    ;; We want to be able to use our new kind of classes directly as type
    ;; specifiers. Make a type expander which returns the class itself.
    ;; Classes are perfectly fine type specifiers.

    (deftype huh (name)
      (intern-huh-class name)) )

  #+SBCL
  (progn
    
    ;; SBCL cannot cope with anonymous classes. The FASL dumper despite our
    ;; MAKE-LOAD-FORM has no idea how to dump it. So we need to actually name them
    ;; and pollute our package with names and have things break when you rename
    ;; packages. But, hey, it's fast!
    
    (defun huh-class-symbol (name)
      (intern (with-standard-io-syntax () (prin1-to-string `(huh ,name))) :huh))

    (defun intern-huh-class (name &optional env)
      (let ((sym (huh-class-symbol name)))
        (or (find-class sym nil env)
            (setf (find-class sym nil env)
                  (make-instance 'huh-class
                                 :name `(huh ,name)
                                 :direct-superclasses (list (find-class 'standard-object))
                                 :huh-name name)))))

    (deftype huh (name)
      (huh-class-symbol name)) ))


;;; DEFMETHOD

;; Unfortunately ANSI-CL says that specializers in DEFMETHOD are symbols. So
;; here is a gross hack: We define a new DEFMETHOD* that allows for type
;; specifiers instead (which of course must be classes). We take the lambda
;; list and replace any specializer with a gensym, if needed, macroexpand the
;; new DEFMETHOD form and then use SUBLIS to replace those gensyms by the
;; actual class objects.

;; This is not guaranteed to work, but it works with CCL, SBCL, ECL, ABCL, and
;; LISPWORKS just fine.

;; If we're lucky we have VARIABLE-INFORMATION and that variable information
;; provides us with expanded types. In that case we actually can define an
;; EXPAND-TYPE function in a somewhat portable way.

;; EXCL has no ENCLOSE, but it has EXCL::%EVAL-COMPILE-TIME which works just
;; as fine.

(eval-when (:compile-toplevel :load-toplevel :execute)

  #+EXCL
  (defun enclose (lambda-expression &optional env)
    (excl::%eval-compile-time lambda-expression env))

  #+(OR CCL SBCL EXCL)
  (defun expand-type (type &optional env)
    (let ((g (gensym)))
      (funcall
       (enclose `(lambda ()
                   (locally
                       (declare (special ,g))
                     (locally
                         (declare (type ,type ,g))
                       (macrolet ((aux (&environment env)
                                    (list 'quote (cdr (assoc 'type (nth-value 2 (variable-information ',g env)))))))
                         (aux)))))
                env)))) )

#+(or CCL SBCL ECL ABCL LISPWORKS)
(defmacro defmethod* (&rest args &environment env)
  (multiple-value-bind (name-and-comb lambda-list body)
      (let* ((q (member-if #'listp args)))
        (values (ldiff args q) (car q) (cdr q)))
    (multiple-value-bind (req more)
        (let ((q (member-if (lambda (x) (member x lambda-list-keywords)) lambda-list)))
          (values (ldiff lambda-list q) q))
      (let ((map nil))
        (setq req (mapcar (lambda (x)
                            (cond ((atom x) x)
                                  (t (destructuring-bind (var type) x
                                       (list var
                                             (cond ((symbolp type) type)
                                                   ((typep type '(cons (member huh)))
                                                    (destructuring-bind (name) (cdr type)
                                                      ;; Again SBCL is pretty fucked up here.
                                                      #+SBCL (huh-class-symbol name)
                                                      #-SBCL (intern-huh-class name)))
                                                   (t
                                                    (let ((type (or #+(OR CCL SBCL EXCL)
                                                                    (expand-type type env)
                                                                    type)))
                                                      type))))))))
                          req))
        (sublis map (macroexpand
                     `(defmethod ,@name-and-comb (,@req ,@more) ,@body)
                     env))))))


;;;; Test it:

;; Tests

;; The TYPE-OF-VAR macro should return the declared type of a variable as a
;; quoted form. If we're lucky the CLtL2 lexical environment access is
;; available.

;; Later we might want to figure out the type of a form. CCL has
;; CCL::NX-FORM-TYPE which does exactly that, for other Lisps we might be able
;; to find a similiar function.

(defmacro type-of-var (x &environment env)
  (declare (ignorable x env))
  ;; #+CCL `',(ccl::nx-form-type x env)
  #-(OR ABCL ECL CMU)
  `',(#+EXCL cadr
      #-EXCL cdr
      (or (assoc 'type (nth-value 2 (variable-information x env)))
              '(nil . t))))

(defun foo ()
  (let ((x (make-instance (intern-huh-class '(pointer int)))))
    (declare (type (huh (pointer int)) x)
             (ignorable x))
    (type-of-var x)))

;; (FOO) should eval to (HUH (POINTER INT)) or #<HUH-CLASS ...>

(defun bar ()
  (let ((x 42))
    (declare (type integer x)           ;to verify VARIABLE-INFORMATION does its job
             (ignorable x))
    (type-of-var x)))

;; Can we at least dump such a class?

(defun my-huh-class ()
  (macrolet ((aux ()
               (intern-huh-class '(pointer int))))
    (aux)))

(defgeneric blah (x))

(defmethod blah ((x t))
  ':dunno)

#+(or CCL SBCL ECL ABCL LISPWORKS)
(defmethod* blah ((x (huh (pointer int))))
  ':hey-this-is-a-pointer-int)

(defun test-blah ()
  (blah (make-instance (intern-huh-class '(pointer int)))))

;;; You should get:

;;
;; (MY-HUH-CLASS) -> #<HUH-CLASS (HUH (POINTER INT))>
;; (BAR) -> INTEGER
;; (FOO) -> (HUH (POINTER INT)) or #<HUH-CLASS (HUH (POINTER INT))>
;; (TEST-BLAH) -> :hey-this-is-a-POINTER-INT
;;