blob: 237271428c990fd1a2b9e1cb3d9fd61acd66bf59 (
about) (
plain)
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
|
;;; print-modules.scm -- print routines for module-related AST structures
;;;
;;; author : Sandra Loosemore
;;; date : 6 Jan 1992
;;;
;;;
;;; This file corresponds to the file ast/modules.scm.
;;; Note: by default, only the module name is printed. To print the
;;; full module, the function print-full-module must be called.
(define *print-abbreviated-modules* '#t)
(define-ast-printer module (object xp)
(if *print-abbreviated-modules*
(begin
(write-string "Module " xp)
(write-string (symbol->string (module-name object)) xp))
(do-print-full-module object xp)))
(define (print-full-module object . maybe-stream)
(let ((stream (if (not (null? maybe-stream))
(car maybe-stream)
(current-output-port))))
(dynamic-let ((*print-abbreviated-modules* '#f))
(pprint object stream))))
(define (do-print-full-module object xp)
(dynamic-let ((*print-abbreviated-modules* '#t))
(let ((modid (module-name object))
(exports (module-exports object))
(body (append (module-imports object)
(module-fixities object)
(module-synonyms object)
(module-algdatas object)
(module-classes object)
(module-instances object)
(if (or (not (module-default object))
(eq? (module-default object)
*standard-module-default*))
'()
(list (module-default object)))
(module-decls object))))
(write-string "module " xp)
(write-modid modid xp)
(when (not (null? exports))
(write-whitespace xp)
(write-commaized-list exports xp))
(write-wheredecls body xp))))
(define-ast-printer import-decl (object xp)
(let ((modid (import-decl-module-name object))
(mode (import-decl-mode object))
(specs (import-decl-specs object))
(renamings (import-decl-renamings object)))
(with-ast-block (xp)
(write-string "import " xp)
(write-modid modid xp)
(if (eq? mode 'all)
(when (not (null? specs))
(write-whitespace xp)
(write-string "hiding " xp)
(write-commaized-list specs xp))
(begin
(write-whitespace xp)
(write-commaized-list specs xp)))
(when (not (null? renamings))
(write-whitespace xp)
(write-string "renaming " xp)
(write-commaized-list renamings xp))
)))
(define-ast-printer entity-module (object xp)
(write-modid (entity-name object) xp)
(write-string ".." xp))
(define-ast-printer entity-var (object xp)
(write-varid (entity-name object) xp))
(define-ast-printer entity-con (object xp)
(write-tyconid (entity-name object) xp))
(define-ast-printer entity-abbreviated (object xp)
(write-tyconid (entity-name object) xp)
(write-string "(..)" xp))
(define-ast-printer entity-class (object xp)
(with-ast-block (xp)
(write-tyclsid (entity-name object) xp)
(write-whitespace xp)
(write-delimited-list (entity-class-methods object) xp
(function write-varid) "," "(" ")")))
(define-ast-printer entity-datatype (object xp)
(with-ast-block (xp)
(write-tyconid (entity-name object) xp)
(write-whitespace xp)
(write-delimited-list (entity-datatype-constructors object) xp
(function write-conid) "," "(" ")")))
(define-ast-printer renaming (object xp)
(with-ast-block (xp)
(write-varid-conid (renaming-from object) xp)
(write-string " to" xp)
(write-whitespace xp)
(write-varid-conid (renaming-to object) xp)))
;;; *** Should it omit precedence if it's 9?
(define-ast-printer fixity-decl (object xp)
(let* ((fixity (fixity-decl-fixity object))
(associativity (fixity-associativity fixity))
(precedence (fixity-precedence fixity))
(ops (fixity-decl-names object)))
(with-ast-block (xp)
(cond ((eq? associativity 'l)
(write-string "infixl " xp))
((eq? associativity 'r)
(write-string "infixr " xp))
((eq? associativity 'n)
(write-string "infix " xp)))
(write precedence xp)
(write-whitespace xp)
(write-delimited-list ops xp (function write-varop-conop) "," "" ""))))
|