A 1/3 or less of the way reimplementation of kkk.lisp, which (used to be) utilities for hacking on SBCL / writing a good deal less CL / a "metaprogramming core" for Cl, seeing as people don't really metaprogram that much

kkk.lisp

;; http://cincyisit.com/events-and-learning
;; https://www.cintrifuse.com/cintrifuse-role-for-greater-cincinnati/
(defvar metaprogamming-systems
  '(:anaphora :cl-ppcre :optima :fare-quasiquote :named-readtables :fare-utils
    :fare-utils :optima.ppcre :FARE-QUASIQUOTE-OPTIMA :FARE-QUASIQUOTE-readtable
    :sb-introspect))

(defvar graphics-systems
  '(:mcclim :mcclim-bezier :mcclim-bezier-clx :mcclim-clx-fb :clim-widgets
    :climacs :clouseau :clim-listener))

;; (loop for x in (list-all-packages)
;;       do (sb-ext::unlock-package x)
;;       (format t "~%; Unlocking ~s" x))

(defun infos (sym)
  `(,sym
    ,@(remove-if-not 'third
		     (loop for o across sb-c::*info-types*
			   when o collect (let* ((category (slot-value o 'SB-C::CATEGORY))
						 (kind (slot-value o 'sb-c::kind)))
					    (list category kind (sb-c::info category kind sym)))))))

(defun alias (f1 f2)
  (loop for (class type x) in (rest (infos f1))
	do (setf (sb-c::info class type f2) x)
     finally (return (values (infos f2) f1))))

(defun docs (k)
  (loop for x being the present-symbols of (find-package k) do (describe x)))

(defun take (n l) (loop repeat n for e in l collect e))

(alias 'UIOP/STREAM:READ-FILE-LINES 'lines)
(alias 'ql-dist::system-apropos '?system)
(alias 'ql-dist::system-apropos-list '?systems)
(alias 'defun 'f)
(alias 'macrolet 'mlet)
(alias 'apropos '?)
(alias 'apropos-list '?s)
(alias 'describe '??)
(alias 'cl::defmethod 'fn)
(alias 'cl::defgeneric 'gf)
(alias 'defmacro 'm)
(alias 'define-symbol-macro 'cheat)
(alias 'defparameter 'var)
(alias 'destructuring-bind 'dlet)
(alias 'multiple-value-bind 'mvb)
(alias 'rename-file 'mv)

(cheat rt *readtable*)
(cheat pkg *package*)
(cheat pkgs (list-all-packages))
(cheat kpkg SB-INT:*KEYWORD-PACKAGE*)
(cheat systems ASDF/FIND-SYSTEM:*DEFINED-SYSTEMS*)
(cheat dir *default-pathname-defaults*)
(cheat q (save-lisp-and-die (format nil "m~a" (symbol-name (gensym))) :executable t))
(cheat ls (ls dir))
(cheat out *standard-output*)
(cheat in *standard-input*)
(cheat &keys LAMBDA-LIST-KEYWORDS)

(var pwd (setf dir #p"/"))

(f ls (dir)
  (let* ((v0 nil))
    (sb-ext::map-directory (lambda (p) (push p v0))
			   dir
			   :directories t
			   :files t)
    v0))

(f dirs (dir)
  (let* ((v0 nil))
    (sb-ext::map-directory (lambda (p) (push p v0))
			   dir
			   :directories t
			   :files nil)
    v0))

(f files (dir)
  (let* ((v0 nil))
    (sb-ext::map-directory (lambda (p) (push p v0))
			   dir
			   :directories nil
			   :files t)
    v0))

(f f? (a) (assert (not (boundp a))) (when (fboundp a) a))
(f var? (a) (assert (not (fboundp a))) (when (boundp a) a))
(f both? (a) (when (and (fboundp a) (boundp a)) a))

(f load-system (a)
   (asdf::operate 'asdf::compile-op a :force t)
   (asdf::operate 'asdf::load-op a :force t))

(f source (sym &optional source)
  (if source (setf (sb-c::info :RANDOM-DOCUMENTATION :STUFF sym) source)
      (sb-c::info :RANDOM-DOCUMENTATION :STUFF sym)))

(f ->s (o) 
   (typecase o
     (string o)
     (symbol (symbol-name o))
     (SB-IMPL::STRING-OUTPUT-STREAM (cl::make-string-output-stream))))

(f ->k (o) 
   (typecase o
     (string (intern (string-upcase o) 'keyword))
     (symbol (intern (symbol-name o) 'keyword))))

(f ->class (o)
   (typecase o
     (symbol (find-class o nil))
     (t (find-class (type-of o) nil))))

(f repl-prompt (stream)
  (format stream "~%~A,~A,~A> " 
	  (package-name *package*)
	  (readtable-name *readtable*)
	  SB-KERNEL:*EVAL-CALLS*)
  (force-output stream))

(f ->lambda-list (l)
  (loop with nicknames = '((p pathname)
			   (s string)
			   (o t)
			   (l list)
			   (i symbol)
			   (pkg package))
     for o in l
     for x = (find o nicknames :key 'car)
     collect (or x o)))

(fn up ((o t)) (slot-value o (slot-value (first (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
(fn left ((o t)) (slot-value o (slot-value (second (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
(fn down ((o t)) (slot-value o (slot-value (third (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
(fn right ((o t)) (slot-value o (slot-value (fourth (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))

(f init-hook ()
  (setf rt (find-readtable :fare-quasiquote)
	sb-int:*repl-prompt-fun* 'REPL-PROMPT
	*INIT-HOOKS* '(init-hook)
	*compile-print* t
	*compile-verbose* t
	*load-print* t
	*load-verbose* t))

(f moral-compass (stream)
  (let* ((*print-length* 3)
	 (n (length (write-to-string pwd))))
    (labels ((adjust () (loop repeat n do (write-char #\space stream))))
      (dlet (uarrow larrow rarrow vbreak darrow)
	  '("      A     " 
	    " <-- " " --> "
	    "      |     "
	    "      V     ")
	;; UP
	;;(adjust)
	(fresh-line stream)
	(write (up pwd) :stream stream)
	(fresh-line stream)
	(adjust)
	(princ uarrow)
	(fresh-line stream)
	(adjust)
	(princ vbreak)
	(fresh-line stream)

	;; CENTER
	(write (left pwd) :stream stream)
	(princ larrow)
	(write pwd :stream stream)
	(princ rarrow)
	(write (right pwd) :stream stream)
	(fresh-line stream)

	;; DOWN
	(adjust)
	(princ vbreak)
	(fresh-line stream)
	(adjust)
	(princ darrow)
	(fresh-line stream)
	(adjust)
	(write (down pwd) :stream stream)
	(fresh-line stream)
	(values)))))

(defmethod lisp ((p pathname)) (uiop/stream:read-file-forms p))

(f out (control-string &rest format-arguments) 
  (apply 'format (list t control-string format-arguments))
  (force-output))
 
(var ed-grammer
     '((:+ :- :move :rename :redefinition :local->global :global->local)
       ((:f)	
	(:var )
	(:macro "MACRO")
	(:symbol-macro "SYMBOL-MACRO")
	(:eval-when)
	(:docstring)
	(:toplevel-form)
	(:internal-progn)
	(:declaration)
	(:comment)
	(:package)
	(asdf::defsystem 'system)))
     "What ED functionality do we get by lisping? 

- MULTIPLE-VALUE-BIND wrapping / unwrapping with var name propogation 
- exposing &KEY arguments of underlying functions
- marking of FUNCALLs that need to be updated on arglist update
- propogate of FUNCTION arguments into caller's lambda-list with keypress
- diff with sbcl internals for special forms

or :READTABLE :PACKAGE :CLASS :SYSTEM
   :COMPILER-MACRO :READ-MACRO :EVAL-WHEN
   :PERMUTATION :GLOBAL :LOCAL
                :VARIABLE :FUNCTION :MACRO :SYMBOL-MACRO
                :FORM :COMMENT :DOCSTRING")

;;; UTIL FUNCTIONS
;;; ============================================================================

(defgeneric args (o))
(defmethod args ((i symbol)) (sb-introspect:function-lambda-list i))

(defun trim (s)
  (string-right-trim '(#\space #\newline #\tab)
		     (string-left-trim '(#\space #\newline #\tab) s)))

(defun specification-f? (name args body)
  (when (or (and (= 1 (length body))
		 (stringp (car body)))
	    (null body))
    name))

(defun removes (removes sequence &rest args
		&key from-end (test #'eql)
		  test-not (start 0)
		  end count key)
  (loop with v0 = sequence
     for remove in removes
     do (setf v0 (remove remove v0
			 :key key
			 :from-end from-end
			 :test test
			 :test-not test-not
			 :start start
			 :end end
			 :count count))
     finally (return-from removes v0)))

(defun method-f? (name args body)
  (SB-PCL::FIND-GENERIC-FUNCTION name nil))

(defun defun-f? (name args body) (and name args body))

(m f (name args &rest body)
   (cond ((specification-f? name args body)
	  (remove nil `(defgeneric ,name ,(mapcar 'car (->lambda-list args))
			 ,(when body `(:documentation ,@body)))))
	 ((method-f? name args body)
	  `(defmethod ,name ,(->lambda-list args) ,@body))
	 ((defun-f? name args body)
	  `(defun ,name ,(mapcar 'car (->lambda-list args)) ,@body))
	 (t "Unparseable F signature: ~S ~S ~S" name args body)))

(f name (o) "PACKAGE-NAME & friends are redundant")
(f source (o) "the source FORM that defined OBJECT")
(f lisp (o) "the source FORM that would currently define OBJECT")
(f more (o) "`(,OBJECT ,@INTERESTING-BRANCHES) allowing for CAR to reduce a graph node in place")
(f up (o))
(f down (o))
(f left (o))
(f right (o))

;;; FUNCTION IMPLEMENTATIONS -- OR -- METHODS
;;; ============================================================================

;; (f lisp ((sym 'asdf::system)))
;; (f lisp ((pkg cl::package)) (fare-util::make-defpackage-form *package* :gensym))

;; (f ?arg)
;; (f ?ftype)
;; (f ?f)
;; (f ?var) 
;; (f ?class)

;;; NEW FRIENDS -- OR -- THE F & M MACROS
;;; ============================================================================

;; (m f (name args &rest body)
;;    "Abstracts over CL::DEFUN, CL::DEFGENERIC & CL::DEFMETHOD"
;;    (match (symbol-name name)
;; 	  ((ppcre "^->(\\S*)" nickname) nickname)

;; 	  (t (match `(,name ,args ,@body)
	  
;; 		    (`(,name ,args ,(and (type string) (variable docstring)))
;; 		     `(defgeneric ,name ,(->lambda-list args)
;; 			(:documentation ,docstring)))

;; 		    ((some 'listp (->lambda-list args))
;; 		     `(defmethod ,name ,(->lambda-list args) ,@body))

;; 		    (t `(defun ,name ,(->lambda-list args) ,@body))))))


;; (f parse-sources ()
;;  "pathnames change, and must be OPEN CLOSEd so we iterate through once on init
;; assigning SOURCE-FORMS into INFOS, then update on redefinition CONDITIONS.

;; SBCL has what should be docstrings as comments above functions for no good 
;; reason. They are moved intom

;; Seeing as each SOURCE (or LISP) is a graph of FUNCALLs, we should be able to
;; dump a buildable set of files for arbitrary lisp code")