source: project/release/4/9ML-toolkit/trunk/ulp.scm @ 23838

Last change on this file since 23838 was 23838, checked in by Ivan Raikov, 10 years ago

9ML-toolit: commit octave/mlton platform

File size: 13.4 KB
Line 
1;
2;;  NineML user layer processor.
3;;
4;;
5;; Copyright 2010-2011 Ivan Raikov and the Okinawa Institute of
6;; Science and Technology.
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22
23(require-extension setup-api extras regex posix utils files data-structures tcp srfi-1 srfi-13)
24(require-extension datatype static-modules miniML miniMLsyntax miniMLvalue miniMLeval)
25(require-extension signal-diagram tree-rewrite ssax sxml-transforms sxpath sxpath-lolevel object-graph uri-generic getopt-long )
26(require-extension 9ML-parse 9ML-repr )
27       
28(include "SXML.scm")
29(include "SXML-to-XML.scm")
30
31(define-values (env-binding? env-empty env-add-signature env-add-module env-add-type env-add-spec env-add-value
32                env-find-value env-find-type env-find-module env-find)
33  (make-mod-env core-syntax))
34
35(define-values (scope-typedecl scope-modtype scope-signature scope-modterm scope-moddef)
36  (make-mod-scoping core-syntax core-scoping))
37
38(define-values (check-modtype check-signature type-modterm type-moddef type-definition)
39  (make-mod-typing core-syntax core-typing))
40
41(include "NineMLcore.scm")
42(include "NineMLsignal.scm")
43(include "NineMLdiagram.scm")
44(include "NineMLinterval.scm")
45(include "NineMLgraph.scm")
46(include "NineMLivp.scm")
47
48
49(define init-scope      (make-parameter st-empty))
50(define init-type-env   (make-parameter env-empty))
51(define init-eval-env   (make-parameter env-empty))
52
53
54(define (enter-typedecl id decl)
55  (init-scope (st-enter-type id (init-scope)))
56  (init-type-env   (env-add-type id decl (init-type-env))))
57
58(define (enter-valtype name ty)
59  (let ((id (ident-create name)))
60    (init-scope (st-enter-value id (init-scope)))
61    (init-type-env   (env-add-value id ty (init-type-env)))))
62
63(define (enter-val name val)
64  (let ((id (or (and (ident? name) name) (ident-create name))))
65    (init-eval-env (ident-add id val (init-eval-env)))))
66
67(core-initialize enter-typedecl enter-valtype)
68(eval-cbv-initialize enter-val)
69
70
71(define (enter-module id mty)
72  (init-scope (st-enter-module id (init-scope)))
73  (init-type-env (env-add-module id mty (init-type-env))))
74
75
76
77(define opt-defaults
78  `(
79    ))
80
81
82(define (defopt x)
83  (lookup-def x opt-defaults))
84
85(define opt-grammar
86  `(
87
88    (print-type-env  "prints the type environment of each operand"
89                     (single-char #\t)
90                     (value (optional COMPONENT-LIST)
91                            (default all)
92                            (transformer 
93                             ,(lambda (x) 
94                                (if (string=? x "all") x
95                                    (list (string-split x ",")))))))
96
97    (print-eval-env  "prints the evaluation environment of each operand"
98                     (single-char #\e)
99                     (value (optional COMPONENT-LIST)
100                            (default all)
101                            (transformer 
102                             ,(lambda (x) 
103                                (if (string=? x "all") x
104                                    (list (string-split x ",")))))))
105
106    (print-source-defs  "prints the source definitions of each operand"
107                        (single-char #\s))
108
109    (output-sxml        "sets output format to SXML")
110
111    (output-xml         "sets output format to XML")
112
113    (platform        "simulation platform (one of chicken, mlton, octave, octave/mlton)"
114                     (value (required PLATFORM)
115                            (predicate 
116                             ,(lambda (x) 
117                                (let ((s (string->symbol (string-downcase x))))
118                                  (case s
119                                    ((chicken mlton octave octave/ml) s)
120                                    (else (error 'ivp "unrecognized platform" x))))))
121                            (transformer ,string->symbol)
122                             ))
123
124    (verbose          "print commands as they are executed"
125                      (single-char #\v))
126
127    (help  "Print help"
128            (single-char #\h))
129 
130  ))
131
132
133;; Use args:usage to generate a formatted list of options (from OPTS),
134;; suitable for embedding into help text.
135(define (ulp:usage)
136  (print "Usage: " (car (argv)) " [options...] operands ")
137  (newline)
138  (print "Where operands are NineML user layer files")
139  (newline)
140  (print "The following options are recognized: ")
141  (newline)
142  (width 35)
143  (print (parameterize ((indent 5)) (usage opt-grammar)))
144  (exit 1))
145
146
147;; Process arguments and collate options and arguments into OPTIONS
148;; alist, and operands (filenames) into OPERANDS.  You can handle
149;; options as they are processed, or afterwards.
150
151(define opts    (getopt-long (command-line-arguments) opt-grammar))
152(define opt     (make-option-dispatch opts opt-grammar))
153
154(define ulp-verbose (make-parameter 0))
155(define data-dir (make-parameter #f))
156(define simulation-platform (make-parameter #f))
157
158(define (d fstr . args)
159  (let ([port (current-error-port)])
160    (if (positive? (ulp-verbose)) 
161        (begin (apply fprintf port fstr args)
162               (flush-output port) ) )))
163
164
165(define (get-data-dir)
166  (or (opt 'data-dir)
167      (or (data-dir)
168          (let ([dir (create-temporary-directory)])
169            (data-dir dir)
170            dir ) ) ))
171
172
173(define (run:execute explist)
174  (define (smooth lst)
175    (let ((slst (map ->string lst)))
176      (string-intersperse (cons (car slst) (cdr slst)) " ")))
177  (for-each (lambda (cmd) (system (->string cmd)))
178            (map smooth explist)))
179
180
181(define (run:execute* explist)
182  (define (smooth lst)
183    (let ((slst (map ->string lst)))
184      (string-intersperse (cons (car slst) (cdr slst)) " ")))
185  (for-each (lambda (cmd) (system* "~a" cmd))
186            (map smooth explist)))
187
188
189(define-syntax run
190  (syntax-rules ()
191    ((_ exp ...)
192     (begin
193       (d "running ~A ...~%" (list `exp ...))
194       (run:execute* (list `exp ...))))))
195
196
197(define-syntax run-
198  (syntax-rules ()
199    ((_ exp ...)
200     (begin
201       (d "running ~A ...~%" (list `exp ...))
202       (run:execute (list `exp ...))))))
203
204
205(define (create-temporary-directory)
206  (let ((dir (or (get-environment-variable "TMPDIR") 
207                 (get-environment-variable "TEMP") 
208                 (get-environment-variable "TMP") 
209                 "/tmp")))
210    (let loop ()
211      (let* ((n (current-milliseconds))
212             (pn (make-pathname dir (string-append "9ML-ulp-" (number->string n 16)) "tmp")))
213        (cond ((file-exists? pn) (loop))
214              (else (mkdir pn) pn))))))
215
216
217(define (network-failure msg . args)
218  (signal
219   (make-composite-condition
220    (make-property-condition
221       'exn
222       'message "invalid response from server"
223       'arguments args)
224    (make-property-condition 'http-fetch))) )
225
226
227
228(define (make-HTTP-GET/1.1 location user-agent host
229                           #!key
230                           (port 80)
231                           (connection "close")
232                           (accept "*")
233                           (content-length 0))
234  (conc
235   "GET " location " HTTP/1.1" "\r\n"
236   "Connection: " connection "\r\n"
237   "User-Agent: " user-agent "\r\n"
238   "Accept: " accept "\r\n"
239   "Host: " host #\: port "\r\n"
240   "Content-length: " content-length "\r\n"
241   "\r\n") )
242
243(define (match-http-response rsp)
244  (and (string? rsp)
245       (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
246
247(define (response-match-code? mrsp code)
248  (and mrsp (string=? (number->string code) (cadr mrsp))) )
249
250(define (match-chunked-transfer-encoding ln)
251  (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
252
253
254(define (http-fetch uri dest)
255  (d "fetching ~s ...~%" (uri->string uri))
256  (match-let (((_ ((_ host port) ('/ . path) query) _) (uri->list uri)))
257    (let* ((port      (or port 80))
258           (locn      (uri->string (update-uri (update-uri uri scheme: #f) host: #f)))
259           (query     (and query (not (string-null? query)) query))
260           (filedir   (uri-decode-string (string-concatenate (intersperse (if query path (drop-right path 1)) "/"))))
261           (filename  (uri-decode-string (or (and query (cadr (string-split query "="))) (last path))))
262           (dest      (make-pathname dest filedir))
263           (filepath  (make-pathname dest filename)))
264      (if (file-exists? filepath) filepath
265          (begin
266          (d "connecting to host ~s, port ~a ...~%" host port)
267          (let-values ([(in out) (tcp-connect host port)])
268                      (d "requesting ~s ...~%" locn)
269                      (display
270                       (make-HTTP-GET/1.1 locn *user-agent* host port: port accept: "*/*")
271                       out)
272                      (flush-output out)
273                      (d "reading response ...~%")
274                      (let ([chunked #f] [ok-response #f])
275                        (let* ([h1 (read-line in)]
276                               [response-match (match-http-response h1)])
277                          (d "~a~%" h1)
278                          ;;*** handle redirects here
279                          (cond ((response-match-code? response-match 200)
280                                 (set! ok-response #t))
281                                ((response-match-code? response-match 404)
282                                 (d "file not found on server: ~s~%" locn))
283                                (else (network-failure "invalid response from server" h1) ))
284                        (and ok-response
285                            (begin
286                              (let loop ()
287                                (let ([ln (read-line in)])
288                                  (unless (string-null? ln)
289                                    (when (match-chunked-transfer-encoding ln) (set! chunked #t))
290                                    (d "~a~%" ln)
291                                    (loop) ) ) )
292                              (if chunked
293                                  (begin
294                                    (d "reading chunks ...~%")
295                                    (let ([data (read-chunks in)])
296                                      (close-input-port in)
297                                      (close-input-port out)
298                                      (if (not (file-exists? dest)) (mkdir dest))
299                                      (d "writing to ~s~%" filepath)
300                                      (with-output-to-file filepath (cut display data) )
301                                      filepath))
302                                 
303                                  (begin
304                                    (d "reading data ...~%")
305                                    (let ([data (read-string #f in)])
306                                      (close-input-port in)
307                                      (close-input-port out)
308                                      (if (not (file-exists? dest)) (mkdir dest))
309                                      (d "writing to ~s~%" filepath)
310                                      (with-output-to-file filepath (cut display data) binary:)
311                                      filepath)))))
312                        )
313                      )))))))
314
315  (define (read-chunks in)
316    (let get-chunks ([data '()])
317      (let ([size (string->number (read-line in) 16)])
318        (if (zero? size)
319            (string-concatenate-reverse data)
320            (let ([chunk (read-string size in)])
321              (read-line in)
322              (get-chunks (cons chunk data)) ) ) ) ) )
323
324
325
326(define (parse-sxml fpath)
327  (with-input-from-file fpath
328    (lambda () (cons '*TOP* (ssax:xml->sxml (current-input-port) `())))
329    ))
330
331
332(define rule-user-layer-component
333  `( 
334
335     ( (M component (definition $url) $properties) =>
336       (M component (eval-env (M eval-definition $url)) $properties) )
337
338     ( (M component (eval-env $eval-env) $properties) =>
339       (M component (model-module (eval-env-last-entry $eval-env)) $properties) )
340
341     ( (M component (eval-env $eval-env) $properties) =>
342       (M component (model-module (eval-env-last-entry $eval-env)) $properties) )
343
344     ( (M component (model-module $model-module) $properties) =>
345       (eval-term (M apply-terms (Longid (Pdot (entry-name $model-module) "construct")) $properties)) )
346
347     ( (M eval-definition $url ) =>
348       (eval-source (fetch (uri-reference $url)) current-scope current-type-env current-eval-env ) )
349
350     ( (M apply-terms $operator (seq $term $rest)) =>
351       (M apply-terms (Apply $operator $term) $rest) )
352       
353     ( (M apply-terms $operator (seq-empty)) => $operator )
354       
355     ))
356
357
358(define (eval-source def current-scope current-type-env current-eval-env)
359  (let* ((scoped-defs      (scope-moddef (current-scope) defs))
360         (mty              (type-moddef (current-type-env) '() scoped-defs))
361         (type-env         (map (lambda (x) (cases modspec x
362                                                   (Value_sig (id vty) (cons id x))
363                                                   (Type_sig (id decl) (cons id x))
364                                                   (Module_sig (id mty) (cons id x))
365                                                   )) mty))
366         (eval-env         (mod-eval-cbv (current-eval-env) scoped-defs))
367         (unified-env      (list scoped-defs
368                                 (filter (lambda (x) (not (assoc (car x) (init-type-env)))) type-env) 
369                                 (filter (lambda (x) (not (assoc (car x) (init-eval-env)))) eval-env) ))
370         
371         )
372    unified-env
373    ))
374
375
376(define rewrite-ul-components (rewrite-map-tree rule-user-layer-component))
377
378(define (main options operands)
379
380  (if (options 'help) (ivp:usage))
381
382
383  (let ((find-module (lambda (x) (env-find-module x (init-type-env)))))
384    (for-each (lambda (init name) (init name enter-module find-module init-eval-env))
385              (list Signal:module-initialize   
386                    Diagram:module-initialize 
387                    Interval:module-initialize 
388                    Graph:module-initialize
389                    IVP:module-initialize )
390              (list "Signal" "Diagram" "Interval" "Graph" "IVP" )) )
391
392  (if (null? operands)
393      (ulp:usage)
394      (let ((output-type (cond ((options 'output-xml)  'xml)
395                               ((options 'output-sxml) 'sxml)
396                               (else #f))))
397        (if (options 'verbose) (begin (repr-verbose 1) (ivp-verbose 1)))
398        (simulation-platform (or (options 'platform) (defopt 'platform) ))
399        (for-each
400         (lambda (operand)
401
402           (let* ((ul-sxml (parse-sxml operand))
403                  (ul-components ((sxpath `(// component))  ul-sxml))
404                  (ul-terms (rewrite-ul-components ul-components)))
405
406             
407
408             (let ((source-defs (car uenv))
409                   (mty         (cadr uenv))
410                   (eval-env    (caddr uenv)))
411               
412               (let ((type-env-opt (options 'print-type-env)))
413                 (if type-env-opt
414                     (if (and (string? type-env-opt) (string=?  type-env-opt "all"))
415                         (print-type-env mty output-type)
416                         (let ((fc (lambda (x) (and (member (ident-name (car x)) type-env-opt) x))))
417                           (print-type-env mty output-type fc)))
418                     ))
419               
420               (let ((eval-env-opt (options 'print-eval-env)))
421                 (if eval-env-opt
422                     (if (and (string? eval-env-opt) (string=? eval-env-opt "all"))
423                         (print-eval-env eval-env output-eval)
424                         (let ((fc (lambda (x) (and (member (ident-name (car x)) eval-env-opt) x))))
425                           (print-eval-env eval-env output-type fc)))
426                     ))
427               
428               (if (options 'print-source-defs)
429                   (print-source-defs source-defs output-type))
430               
431               
432               )))
433
434         operands))))
435
436(main opt (opt '@))
437
438
439)
440
Note: See TracBrowser for help on using the repository browser.