Coverage report: /home/runner/work/geb/geb/src/specs/geb-printer.lisp

KindCoveredAll%
expression141188 75.0
branch44100.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;; We use CL streams as they are much better for concatenating to, and
2
 ;; have us worry less. they are a mutable interface however.
3
 
4
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5
 ;; FORMAT RUNDOWN FOR THOSE WHO ARE UNFAMILIAR
6
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7
 
8
 ;; https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node257.html
9
 
10
 ;; DSL FOR NEWLINES AND CONTROL OF IT
11
 
12
 ;; ~4I  = (pprint-indent :block   4)
13
 ;; ~4:I = (pprint-indent :current 4)
14
 ;; ~_   = (pprint-newline :linear)
15
 ;; ~@_  = (pprint-newline :miser)
16
 ;; ~:@_ = (pprint-newline :mandatory)
17
 ;; ~:_  = (pprint-newline :fill)
18
 
19
 
20
 ;; FOR PRINTING NORMALLY NOTE THESE TAKE ARGUMENTS!
21
 
22
 ;; ~(~a~)    = print symbol lower case instead of upper case
23
 ;; ~{~A~}    = prints a list element by element.
24
 
25
 ;; ~{~A~^ ~} = prints a list element by element, the last element of
26
 ;;             the list does not print the extra space
27
 ;; EXAMPLE:
28
 ;; CL-USER> (format nil "~{~A~^ ~}" (list 1 2 3 4 5))
29
 ;; "1 2 3 4 5"
30
 ;; CL-USER> (format nil "~{~A ~}" (list 1 2 3 4 5))
31
 ;; "1 2 3 4 5 "
32
 
33
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34
 ;; TopLevel Extraction
35
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36
 
37
 (in-package :geb.spec)
38
 
39
 ;; normal s-expression pretty printer.
40
 ;; only doing this as Ι think we want to be reflective in the future.
41
 ;; We can make other printers if we want.
42
 
43
 (defmacro with-alias-overide ((obj stream) &body otherwise)
44
   "Prints out an alias instead of the body if it can detect an alias.
45
 
46
 Effectively this overrides any printing that would naturally occur"
47
   (let ((alias    (gensym))
48
         (in-there (gensym)))
49
     `(multiple-value-bind (,alias ,in-there) (geb.mixins:meta-lookup ,obj :alias)
50
        (if ,in-there
51
            (format ,stream "~W" ,alias)
52
            (progn ,@otherwise)))))
53
 
54
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55
 ;; Subst Constructor Printer
56
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57
 
58
 (defun same-type-to-list (pair type &optional acc)
59
   "converts the given type to a list format"
60
   (if (typep (mcadr pair) type)
61
       (same-type-to-list (mcadr pair) type (cons (mcar pair) acc))
62
       (reverse (list* (mcadr pair) (mcar pair) acc))))
63
 
64
 (-> pair-to-list (pair &optional list) list)
65
 (defun pair-to-list (pair &optional acc)
66
   "converts excess pairs to a list format"
67
   (if (typep (mcdr pair) 'pair)
68
       (pair-to-list (mcdr pair)
69
                     (cons (mcar pair) acc))
70
       (reverse (list* (mcdr pair) (mcar pair) acc))))
71
 
72
 ;; Prefix Prod, collapse
73
 (defmethod print-object ((obj prod) stream)
74
   (with-alias-overide (obj stream)
75
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
76
       (format stream "×~0:I ~{~W~^~_ ~}" (same-type-to-list obj 'prod)))))
77
 
78
 ;; Prefix coprod, collapse
79
 (defmethod print-object ((obj coprod) stream)
80
   (with-alias-overide (obj stream)
81
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
82
       (format stream "+~0:I ~{~W~^~_ ~}" (same-type-to-list obj 'coprod)))))
83
 
84
 (defmethod print-object ((obj so1) stream)
85
   (with-alias-overide (obj stream)
86
     (format stream "s-1")))
87
 
88
 (defmethod print-object ((obj so0) stream)
89
   (with-alias-overide (obj stream)
90
     (format stream "s-0")))
91
 
92
 (defmethod print-object ((obj left) stream)
93
   (pprint-logical-block (stream nil :prefix "(" :suffix ")")
94
     (format stream "left~1:I ~W" (obj obj))))
95
 
96
 (defmethod print-object ((obj right) stream)
97
   (pprint-logical-block (stream nil :prefix "(" :suffix ")")
98
     (format stream "right~1:I ~W" (obj obj))))
99
 
100
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
101
 ;; Subst Morphism Printer
102
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103
 
104
 (defmethod print-object ((obj terminal) stream)
105
   (with-alias-overide (obj stream)
106
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
107
       (format stream "->1~1:I ~W" (obj obj)))))
108
 
109
 (defmethod print-object ((obj init) stream)
110
   (with-alias-overide (obj stream)
111
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
112
       (format stream "0->~1:I ~W" (obj obj)))))
113
 
114
 (defmethod print-object ((obj inject-left) stream)
115
   (with-alias-overide (obj stream)
116
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
117
       (format stream "->left~1:I ~W ~_~W" (mcar obj) (mcadr obj)))))
118
 
119
 (defmethod print-object ((obj inject-right) stream)
120
   (with-alias-overide (obj stream)
121
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
122
       (format stream "->right~1:I ~W ~_~W" (mcar obj) (mcadr obj)))))
123
 
124
 (defmethod print-object ((obj project-left) stream)
125
   (with-alias-overide (obj stream)
126
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
127
       (format stream "<-left~1:I ~W ~_~W" (mcar obj) (mcadr obj)))))
128
 
129
 (defmethod print-object ((obj project-right) stream)
130
   (with-alias-overide (obj stream)
131
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
132
       (format stream "<-right~1:I ~W ~_~W" (mcar obj) (mcadr obj)))))
133
 
134
 (defmethod print-object ((obj case) stream)
135
   (with-alias-overide (obj stream)
136
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
137
       (format stream "case~1:I ~W ~_~W" (mcar obj) (mcadr obj)))))
138
 
139
 (defmethod print-object ((obj comp) stream)
140
   (with-alias-overide (obj stream)
141
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
142
       (format stream "∘~0:I ~{~W~^~_ ~}" (same-type-to-list obj 'comp)))))
143
 
144
 (defmethod print-object ((obj distribute) stream)
145
   (with-alias-overide (obj stream)
146
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
147
       (format stream "dist~1:I ~W ~_~W ~_~W" (mcar obj) (mcadr obj) (mcaddr obj)))))
148
 
149
 (defmethod print-object ((obj pair) stream)
150
   (with-alias-overide (obj stream)
151
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
152
       (format stream "~-1I~{~W~^~_ ~}" (pair-to-list obj)))))
153
 
154
 (defmethod print-object ((obj functor) stream)
155
   (with-alias-overide (obj stream)
156
     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
157
       (format stream "FUNCTOR<>"))))
158
 ����