blob: 207b79d381086eb1ea32bf046f459bbb5bf7e14d (
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
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
|
;;; ==================================================================
;;; This deals with incremental compilation as used by the command interface.
;;; The basic theory is to create new modules which import the entire
;;; symbol table of an existing module.
;;; This adds a new module to the extension environment. This env is an alist
;;; of module names & extended modules.
(define *extension-env* '())
(define (extend-module mod-name new-ast)
(push (tuple mod-name new-ast) *extension-env*))
;;; This cleans out extensions for a module.
(define (remove-extended-modules mod-name)
(setf *extension-env* (rem-ext1 *extension-env* mod-name)))
(define (rem-ext1 env name)
(cond ((null? env)
'())
((eq? (tuple-2-1 (car env)) name)
(rem-ext1 (cdr env) name))
(else
(cons (car env) (rem-ext1 (cdr env) name)))))
(define (clear-extended-modules)
(setf *extension-env* '()))
;;; This retrieves the current extension to a module (if any).
(define (updated-module name)
(let ((name+mod (assq name *extension-env*)))
(if (not (eq? name+mod '#f))
(tuple-2-2 name+mod)
(let ((mod-in-table (table-entry *modules* name)))
(cond ((eq? mod-in-table '#f)
(signal-module-not-ready name))
((eq? (module-type mod-in-table) 'interface)
(signal-cant-eval-interface name))
(else mod-in-table))))))
(define (signal-module-not-ready name)
(fatal-error 'module-not-ready
"Module ~A is not loaded and ready."
name))
(define (signal-cant-eval-interface name)
(fatal-error 'no-evaluation-in-interface
"Module ~A is an interface: evaluation not allowed."
name))
(define (compile-fragment module str filename)
(let ((mod-ast (updated-module module)))
(dynamic-let
((*printers* (if (memq 'extension *printers*) *printers* '()))
(*abort-phase* '#f))
(mlet (((t-code new-ast) (compile-fragment1 module mod-ast str filename)))
(cond ((eq? t-code 'error)
'error)
(else
(eval t-code)
new-ast))))))
(define (compile-fragment1 mod-name mod-ast str filename)
(let/cc x
(dynamic-let ((*abort-compilation* (lambda () (funcall x 'error '()))))
(let* ((mods (parse-from-string
(format '#f "module ~A where~%~A~%" mod-name str)
(function parse-module-list)
filename))
(new-mod (car mods)))
(when (not (null? (cdr mods)))
(signal-module-decl-in-extension))
(when (not (null? (module-imports new-mod)))
(signal-import-decl-in-extension))
(fragment-initialize new-mod mod-ast)
(values (modules->lisp-code mods) new-mod)))))
(define (signal-module-decl-in-extension)
(fatal-error 'module-decl-in-extension
"Module declarations are not allowed in extensions."))
(define (signal-import-decl-in-extension)
(fatal-error 'import-decl-in-extension
"Import declarations are not allowed in extensions."))
;;; Copy stuff into the fragment module structure from its parent module.
;;; The inverted symbol table is not necessary since the module contains
;;; no imports.
(define (fragment-initialize new old)
(setf (module-name new) (gensym))
(setf (module-type new) 'extension)
(setf (module-unit new) (module-unit old))
(setf (module-uses-standard-prelude? new)
(module-uses-standard-prelude? old))
(setf (module-inherited-env new) old)
(setf (module-fixity-table new)
(copy-table (module-fixity-table old)))
(setf (module-default new) (module-default old)))
;;; This code deals with the actual evaluation of Haskell code.
;;; This decides whether a variable has type `Dialogue'.
(define (io-type? var)
(let ((type (var-type var)))
(when (not (gtype? type))
(error "~s is not a Gtype." type))
(and (null? (gtype-context type))
(is-dialogue? (gtype-type type)))))
(define (is-dialogue? type)
(let ((type (expand-ntype-synonym type)))
(and (ntycon? type)
(eq? (ntycon-tycon type) (core-symbol "Arrow"))
(let* ((args (ntycon-args type))
(a1 (expand-ntype-synonym (car args)))
(a2 (expand-ntype-synonym (cadr args))))
(and
(ntycon? a1)
(eq? (ntycon-tycon a1) (core-symbol "SystemState"))
(ntycon? a2)
(eq? (ntycon-tycon a2) (core-symbol "IOResult")))))))
(define (is-list-of? type con)
(and (ntycon? type)
(eq? (ntycon-tycon type) (core-symbol "List"))
(let ((arg (expand-ntype-synonym (car (ntycon-args type)))))
(and (ntycon? arg) (eq? (ntycon-tycon arg) con)))))
(define (apply-exec var)
(initialize-io-system)
(mlet (((_ sec)
(time-execution
(lambda ()
(let/cc x
(setf *runtime-abort* (lambda () (funcall x 'error)))
(let ((fn (eval (fullname var))))
(unless (var-strict? var)
(setf fn (force fn)))
(funcall fn (box 'state))))))))
(say "~%")
(when (memq 'time *printers*)
(say "Execution time: ~A seconds~%" sec)))
'done)
(define (eval-module mod)
(dolist (v (module-vars mod))
(when (io-type? v)
(when (not (string-starts? "temp_" (symbol->string (def-name v))))
(say/ne "~&Evaluating ~A.~%" v))
(apply-exec v))))
(define (run-program name)
(compile/load name)
(let ((main-mod (table-entry *modules* '|Main|)))
(if main-mod
(let ((main-var (table-entry (module-symbol-table main-mod) '|main|)))
(if main-var
(apply-exec main-var)
(error "Variable main missing")))
(error "module Main missing"))))
|
