~remexre/nrutil

ref: 24237db0fabb5a6043b54bf504765caad4fbb25a nrutil/main.lisp -rw-r--r-- 6.9 KiB
24237db0Nathan Ringo avoid capturing slot names 5 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
(uiop:define-package :nrutil/main
  (:nicknames :nrutil)
  (:use :c2cl :iterate)
  (:import-from :alexandria #:with-gensyms)
  (:import-from :trivial-types #:tuple #:type-specifier-p)
  (:export #:data-class #:dbg #:def-data-class #:defun/typed #:genint #:print-object-pretty #:tuple))
(in-package :nrutil/main)

(defmacro defun/typed (name args ret &body body)
  (check-type name symbol)
  (let (defun-args mode type-args)
    (iter
      (for arg in args)
      (etypecase arg
        ((eql &key)
         (unless (member mode '(nil))
           (error "Invalid use of &key"))
         (push '&key defun-args)
         (push '&key type-args)
         (setf mode '&key))
        ((member '(&optional &rest))
         (error "Not supported: ~s" arg))
        (symbol
          (ecase mode
            ((nil)
              (push arg defun-args)
              (push t type-args))
            ((&key)
              (let ((keyword-name (intern (symbol-name arg) "KEYWORD")))
                (push arg defun-args)
                (push `(,keyword-name t) type-args)))))
        (cons
          (ecase mode
            ((nil)
              (push (first arg) defun-args)
              (push (second arg) type-args))
            ((&key)
             (let (keyword-name var
                   (arg-type (car (last arg))))
               (etypecase (first arg)
                 (symbol
                   (setf keyword-name (intern (symbol-name (first arg)) "KEYWORD")
                         var (first arg)))
                 (cons
                   (setf keyword-name (caar arg)
                         var (cdar arg))))
               (push (list keyword-name arg-type) type-args)
               (push (butlast arg) defun-args)))))))
    (unless (and (consp ret) (eq (car ret) 'values))
      (setf ret `(values ,ret &optional)))
    `(progn
       (declaim (ftype (function ,(nreverse type-args) ,ret) ,name))
       (defun ,name ,(nreverse defun-args) ,@body))))

(deftype self-evaluating ()
  "The type of self-evaluating forms."
  '(or number character string bit-vector null keyword))

(deftype type-specifier ()
  "A type specifier. Only use this in macros!"
  '(satisfies type-specifier-p))

(defclass data-class ()
  ()
  (:documentation "A mixin for printing object graphs READably."))

(defun/typed print-data-class-object-readably ((object data-class) (stream stream)) null
  (let ((class (class-of object)))
    (pprint-logical-block (stream nil)
      (format stream "#.(~s '~s " 'make-instance (class-name class))
      (pprint-indent :block 4 stream)
      (pprint-newline :fill stream)
      (pprint-logical-block (stream nil)
        (iter
          (for slot in (class-slots class))
          (unless (slot-boundp-using-class class object slot)
            (next-iteration))
          (unless (first-time-p)
            (write-char #\Space stream)   
            (pprint-newline :linear stream))
          (format stream "~s " (or (first (slot-definition-initargs slot))
                                   (slot-definition-name slot)))
          (let ((value (slot-value-using-class class object slot)))
            (unless (typep value 'self-evaluating)
              (write-char #\' stream))
            (write value :stream stream))))
      (write-char #\) stream)))
  nil)

(defgeneric print-object-pretty (object stream)
  (:documentation "Pretty-prints an object. Used to override the print-object
                   method defined by def-data-class. Defaults to calling
                   print-object with *print-readably* set to t.")
  (:method (object stream)
     (let ((*print-readably* t))
       (print-object object stream))))

(defmethod print-object ((object data-class) stream)
  (if *print-readably*
      (print-data-class-object-readably object stream)
      (print-object-pretty object stream)))

(defun/typed merge-plist ((a list) (b list)) list
  "Merges two plists, preferring keys in B."
  (let ((values (make-hash-table)))
    (iter
      (while a)
      (setf (gethash (car a) values) (cadr a))
      (setf a (cddr a)))
    (iter
      (while b)
      (setf (gethash (car b) values) (cadr b))
      (setf b (cddr b)))
    (iter
      (for (k v) in-hashtable values)
      (nconcing (list k v)))))

(defmacro def-data-class (name superclasses fields &rest class-options)
  "Defines a class with mandatory fields, a constructor function that wraps
   make-instance (using positional arguments rather than keyword arguments),
   and a print-object instance that prints READably."
  (check-type name symbol)
  (labels ((symbol-package-unless-cl (sym)
             (check-type sym symbol)
             (let ((cl (find-package :cl))
                   (pkg (symbol-package sym)))
               (unless (eq cl pkg)
                 pkg)))
           (slashed-symbol (a b)
             (check-type a symbol)
             (check-type b symbol)
             (intern
               (format nil "~a/~a" (symbol-name a) (symbol-name b))
               (or
                 (symbol-package-unless-cl a)
                 (symbol-package-unless-cl b)
                 *package*))))
    (iter
      (for field in fields)
      (when (symbolp field)
        (setf field (list field t)))
      (check-type field (cons symbol (cons t list)))
      (for field-name = (first field))
      (for field-type = (second field))
      (for kwd = (intern (symbol-name field-name) :keyword))
      (for slot-name = (intern
                         (format nil "%~a" (symbol-name field-name))
                         (or (symbol-package-unless-cl field-name) *package*)))
      (for reader-name = (slashed-symbol name field-name))
      (for spec = (cons slot-name
                        (merge-plist
                          `(:initarg ,kwd
                            :initform (error "Must provide ~s to ~s" ,kwd
                                             '(make-instance ,name))
                            :reader ,reader-name
                            :type ,field-type)
                          (cddr field))))
      (collect spec into class-fields)
      (for var = (gensym))
      (collect `((,kwd ,var) ,(getf (cdr spec) :initform)) into ctor-args)
      (collect (list kwd field-type) into ctor-type-args)
      (appending (list kwd var) into field-kwargs)
      (appending (list kwd `(list 'quote (,reader-name object)))
        into print-object-args)
      (finally (return
                 `(progn
                    (defclass ,name ,(append superclasses (list 'data-class))
                      ,class-fields
                      ,@class-options)
                    (declaim (ftype (function (&key ,@ctor-type-args) (values ,name &optional)) ,name))
                    (defun ,name (&key ,@ctor-args)
                      (make-instance ',name ,@field-kwargs))))))))

(defvar *genint-counter* 0)
(defun/typed genint () number
  (incf *genint-counter*))

(defmacro dbg (expr)
  (with-gensyms (vals)
    `(let ((,vals (multiple-value-list ,expr)))
       (format *debug-io* ,(format nil "~s =~~{ ~~s~~}~~%" expr) ,vals)
       (values-list ,vals))))