source: project/release/4/ersatz/trunk/runtime.scm @ 31371

Last change on this file since 31371 was 31371, checked in by Ivan Raikov, 7 years ago

ersatz release 1.13

File size: 32.1 KB
Line 
1;;
2;;
3;; Runtime functions for the Ersatz template library.
4;;
5;; Based on the Ocaml Jingoo library, which is in turn based on the
6;; Python Jinja2 library.
7;;
8;; Copyright 2012-2014 Ivan Raikov and the Okinawa Institute of
9;; Science and Technology.
10;;
11;; This program is free software: you can redistribute it and/or
12;; modify it under the terms of the GNU General Public License as
13;; published by the Free Software Foundation, either version 3 of the
14;; License, or (at your option) any later version.
15;;
16;; This program is distributed in the hope that it will be useful, but
17;; WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19;; General Public License for more details.
20;;
21;; A full copy of the GPL license can be found at
22;; <http://www.gnu.org/licenses/>.
23;;
24
25; make-char-quotator QUOT-RULES
26;
27; Given QUOT-RULES, an assoc list of (char . string) pairs, return
28; a quotation procedure. The returned quotation procedure takes a string
29; and returns either a string or a list of strings. The quotation procedure
30; check to see if its argument string contains any instance of a character
31; that needs to be encoded (quoted). If the argument string is "clean",
32; it is returned unchanged. Otherwise, the quotation procedure will
33; return a list of string fragments. The input straing will be broken
34; at the places where the special characters occur. The special character
35; will be replaced by the corresponding encoding strings.
36;
37; For example, to make a procedure that quotes special HTML characters,
38; do
39;       (make-char-quotator
40;           '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;")))
41
42(define (make-char-quotator char-encoding)
43  (let ((bad-chars (map car char-encoding)))
44
45    ; Check to see if str contains one of the characters in charset,
46    ; from the position i onward. If so, return that character's index.
47    ; otherwise, return #f
48    (define (index-cset str i charset)
49      (let loop ((i i))
50        (and (< i (string-length str))
51             (if (memv (string-ref str i) charset) i
52                 (loop (+ 1 i))))))
53
54    ; The body of the function
55    (lambda (str)
56      (let ((bad-pos (index-cset str 0 bad-chars)))
57        (if (not bad-pos) str   ; str had all good chars
58            (let loop ((from 0) (to bad-pos))
59              (cond
60               ((>= from (string-length str)) '())
61               ((not to)
62                (cons (substring str from (string-length str)) '()))
63               (else
64                (let ((quoted-char
65                       (cdr (assv (string-ref str to) char-encoding)))
66                      (new-to 
67                       (index-cset str (+ 1 to) bad-chars)))
68                  (if (< from to)
69                      (cons
70                       (substring str from to)
71                       (cons quoted-char (loop (+ 1 to) new-to)))
72                      (cons quoted-char (loop (+ 1 to) new-to))))))))))
73))
74
75;; Returns the first i elements of list x; if the length of x is less
76;; than i, pads the return result with fill-value
77(define (take/pad x i fill-value)
78  (let recur ((i i) (x x) (res '()))
79    (if (positive? i)
80        (if (null? x) 
81            (recur (- i 1) x (cons fill-value res))
82            (recur (- i 1) (cdr x) (cons (car x) res)))
83        (reverse res))))
84 
85
86(define (unbox-int x)
87  (cases tvalue x
88         (Tint (i) i)
89         (else (error 'unbox-int "invalid argument" x))))
90
91(define (unbox-float x)
92  (cases tvalue x
93         (Tfloat (f) f)
94         (else (error 'unbox-float "invalid argument" x))))
95
96(define (unbox-string x)
97  (cases tvalue x
98         (Tstr (s) s)
99         (else (error 'unbox-string "invalid argument" x))))
100
101(define (unbox-bool x)
102  (cases tvalue x
103         (Tbool (b) b)
104         (else (error 'unbox-bool "invalid argument" x))))
105
106(define (unbox-list x)
107  (cases tvalue x
108         (Tlist (lst) lst)
109         (else (error 'unbox-list "invalid argument" x))))
110
111(define (unbox-set x)
112  (cases tvalue x
113         (Tset (lst) lst)
114         (else (error 'unbox-set "invalid argument" x))))
115
116(define (unbox-obj x)
117  (cases tvalue x
118         (Tobj (alst) alst)
119         (else (error 'unbox-obj "invalid argument" x))))
120
121
122(define (ident-expr->name expr)
123  (cases texpr expr
124         (IdentExpr (name) name)
125         (else (error 'ident-expr->name 
126                      "invalid identifier expression"
127                      expr))))
128                   
129
130(define (ident-expr->name/safe expr)
131  (cases texpr expr
132         (IdentExpr (name) name)
133         (else #f)))
134
135(define (merge-defaults defaults kwargs)
136  (map (lambda (nv)
137         (let ((name (car nv)))
138           (cond ((assoc name kwargs) =>
139                  (lambda (value) (cons name value)))
140                 (else
141                  nv))))
142       defaults))
143               
144(define (union-defaults defaults kwargs)
145  (let recur ((alst (merge-defaults defaults kwargs))
146              (kwargs kwargs))
147    (if (null? kwargs) alst
148        (let ((nv (car kwargs)))
149          (let ((name (car nv)))
150            (if (assoc name alst)
151                (recur alst (cdr kwargs))
152                (recur (cons nv alst) (cdr kwargs)))
153            )))
154    ))
155
156
157(define (template-context-with-buffer ctx buffer)
158  (make-template-context
159   (tmpl-ctx-frame-stack ctx)
160   (tmpl-ctx-macro-table ctx)
161   (tmpl-ctx-filter-table ctx)
162   buffer))
163
164
165(define (push-frame ctx)
166    (and (template-context? ctx) 
167         (let ((frame-stack (tmpl-ctx-frame-stack ctx)))
168           (make-template-context (cons '() frame-stack)
169                                  (tmpl-ctx-macro-table ctx)
170                                  (tmpl-ctx-filter-table ctx)
171                                  (tmpl-ctx-buffer ctx)))))
172
173(define (pop-frame ctx)
174    (and (template-context? ctx) 
175         (let ((frame-stack (tmpl-ctx-frame-stack ctx)))
176           (if (null? frame-stack) ctx
177               (let ((frame-stack1 (if (null? (cdr frame-stack))
178                                       frame-stack
179                                       (cdr frame-stack))))
180                 (make-template-context frame-stack1
181                                        (tmpl-ctx-macro-table ctx)
182                                        (tmpl-ctx-filter-table ctx)
183                                        (tmpl-ctx-buffer ctx))))
184           )))
185
186
187
188
189(define (set-value ctx name value)
190  (if (and (template-context? ctx) (symbol? name) (tvalue? value))
191   (let ((frame-stack (tmpl-ctx-frame-stack ctx)))
192     (if (null? frame-stack)
193         (make-template-context (cons `((,name . ,value)) frame-stack)
194                                (tmpl-ctx-macro-table ctx)
195                                (tmpl-ctx-filter-table ctx)
196                                (tmpl-ctx-buffer ctx))
197         (let ((frame (car frame-stack)))
198           (make-template-context (cons (cons `(,name . ,value) frame) (cdr frame-stack))
199                                  (tmpl-ctx-macro-table ctx)
200                                  (tmpl-ctx-filter-table ctx)
201                                  (tmpl-ctx-buffer ctx)))))
202   (else (error 'set-value "invalid arguments" ctx name value))))
203
204
205(define (set-values ctx names values)
206  (and (template-context? ctx)
207       (fold (lambda (name value ctx)
208               (and (symbol? name) (tvalue? value)
209                    (set-value ctx name value)))
210             ctx names values)))
211
212
213(define (bind-names ctx names values)
214  (cond ((and (null? (cdr names)) (tvalue? values))
215         (set-value ctx (car names) values))
216        ((and (pair? (cdr names)) (tvalue-setp values))
217         (set-values ctx names (unbox-set values)))
218        (else ctx)))
219
220
221(define (get-value ctx name)
222  (let recur ((frame-stack (tmpl-ctx-frame-stack ctx)))
223    (if (null? frame-stack) (Tnull)
224        (cond ((assoc name (car frame-stack)) => cdr)
225              (else (recur (cdr frame-stack))))
226        )))
227
228
229(define-inline (get-func ctx name)
230  (let ((value (get-value ctx name)))
231    (cases tvalue value
232           (Tfun (f) value)
233           (else (error 'get-func "undefined function" name)))
234    ))
235
236
237(define (set-macro ctx name macro)
238  (and (template-context? ctx) (symbol? name) (template-macro? macro)
239       (let ((macro-table (tmpl-ctx-macro-table ctx)))
240         (make-template-context (tmpl-ctx-frame-stack ctx)
241                                (cons (cons name macro) macro-table)
242                                (tmpl-ctx-filter-table ctx)
243                                (tmpl-ctx-buffer ctx)))))
244
245
246(define (get-macro ctx name)
247  (and (template-context? ctx)
248       (cond ((assoc name (tmpl-ctx-macro-table ctx)) => cdr)
249             (else #f))
250       ))
251
252
253(define (pop-macro ctx)
254  (and (template-context? ctx)
255       (let ((macro-table (tmpl-ctx-macro-table ctx)))
256         (make-template-context (tmpl-ctx-frame-stack ctx)
257                                (if (null? macro-table) '() (cdr macro-table))
258                                (tmpl-ctx-filter-table ctx)
259                                (tmpl-ctx-buffer ctx)))))
260
261
262(define (set-filter ctx name)
263  (and (template-context? ctx)
264       (let ((filter-table (tmpl-ctx-filter-table ctx)))
265         (make-template-context (tmpl-ctx-frame-stack ctx)
266                                (tmpl-ctx-macro-table ctx)
267                                (cons name filter-table)
268                                (tmpl-ctx-buffer ctx)))))
269
270
271(define (pop-filter ctx)
272  (and (template-context? ctx)
273       (let ((filter-table (tmpl-ctx-filter-table ctx)))
274         (make-template-context (tmpl-ctx-frame-stack ctx)
275                                (tmpl-ctx-macro-table ctx)
276                                (if (null? filter-table) '() (cdr filter-table))
277                                (tmpl-ctx-buffer ctx)))))
278
279
280(define (tfun-apply f args #!key (name "<lambda>") (kwargs '()))
281  (cases tvalue f
282         (Tfun (fn) (fn args kwargs))
283         (else (error 'tfun-apply "invalid function" name f))))
284
285
286(define (tfilters-apply ctx text filters #!key (autoescape #t) (safe #f))
287  (let ((safe.text 
288         (fold (lambda (name safe.text)
289                 (let ((safe (car safe.text))
290                       (text (cdr safe.text)))
291                   (cond ((eq? name 'safe)
292                          (cons #t text))
293                         ((and (eq? name 'escape)
294                               autoescape)
295                          (cons safe text))
296                         (else
297                          (cons safe
298                                (tfun-apply (get-func ctx name) 
299                                            (list text)
300                                            name: name)
301                                ))
302                         )))
303               (cons safe text)
304               filters
305               )))
306   
307    (let ((safe (car safe.text))
308          (text (cdr safe.text)))
309      (if (or safe (not autoescape)) text
310          (if (boolean? autoescape)
311              (op-escape-html (Tstr (->string text)) '())
312              (autoescape (Tstr (->string text)) '()))
313      ))
314    ))
315
316
317(define (tvalue-output ctx v #!key (autoescape #t) (safe #f))
318  (let ((tbl (tmpl-ctx-filter-table ctx)))
319    (cases tvalue v
320           (Tnull () (begin))
321           (else
322            (if (and safe (null? tbl))
323                (display v (tmpl-ctx-buffer ctx))
324                (display (tfilters-apply ctx v tbl safe: safe autoescape: autoescape)
325                         (tmpl-ctx-buffer ctx))
326                ))
327           )))
328               
329       
330(define (tobj-lookup ctx oname pname)
331  (let ((v (get-value ctx oname)))
332    (cases tvalue v
333           (Tobj (alst)
334                 (cond ((assoc pname alst) => cdr)
335                       (else  (Tnull))))
336           (else (Tnull)))
337    ))
338       
339(define (tobjval-lookup v pname)
340  (cases tvalue v
341         (Tobj (alst)
342               (cond ((assoc pname alst) => cdr)
343                     (else  (Tnull))))
344         (else (Tnull)))
345  )
346
347
348(define (iter ctx iterator f iterable)
349
350  (let* ((lst (cases tvalue iterable
351                    (Tlist (lst) lst)
352                    (Tset (lst) lst)
353                    (else (error 'iter "object not iterable" iterable))))
354         (len (length lst)))
355
356
357    (let recur ((ctx ctx) (i 0) (lst lst))
358
359      (if (null? lst) ctx
360         
361          (let ((item (car lst)))
362            (let* ((ctx   (push-frame ctx))
363                   (ctx   (bind-names ctx iterator item))
364                   (cycle (Tfun (lambda (args kwargs)
365                                  (let ((alen (length args)))
366                                    (list-ref args (modulo i alen))))))
367                   (ctx    (set-value ctx 'loop
368                                    (Tobj `((index0    . ,(Tint i))
369                                            (index     . ,(Tint (+ i 1)))
370                                            (revindex0 . ,(Tint (- len i 1)))
371                                            (revindex  . ,(Tint (- len i)))
372                                            (first     . ,(Tbool (= i 0)))
373                                            (last      . ,(Tbool (= i (- len 1))))
374                                            (length    . ,(Tint len))
375                                            (cycle     . ,cycle)))))
376                   (ctx  (f ctx))
377                   (ctx  (pop-frame ctx)))
378             
379              (recur ctx (+ i 1) (cdr lst))
380              )))
381      )))
382
383
384             
385(define (eval-macro  env ctx macro-name args kwargs macro f  #!key (caller #f))
386  (let ((arg-names (tmpl-mac-args macro))
387        (defaults  (tmpl-mac-defaults macro))
388        (code      (tmpl-mac-code macro)))
389
390    (let ((args-len      (length args))
391          (arg-names-len (length arg-names)))
392
393      (if (< args-len arg-names-len)
394          (error 'eval-macro "macro called with wrong number of arguments" 
395                 (list macro-name arg-names)
396                 args))
397
398      (let* ((ctx  (push-frame ctx))
399             (ctx  (set-value ctx 'varargs (Tlist (drop args arg-names-len))))
400             (ctx  (set-value ctx 'kwargs  (Tobj kwargs)))
401             (ctx  (set-value ctx macro-name
402                              (Tobj `((name         . ,(Tstr (->string macro-name)))
403                                      (arguments    . ,(Tlist (map (compose Tstr ->string) arg-names)))
404                                      (defaults     . ,(Tobj defaults))
405                                      (catch_kwargs . ,(Tbool (not (null? kwargs))))
406                                      (catch_vargs  . ,(Tbool (> args-len arg-names-len)))
407                                      (caller       . ,(Tbool caller))
408                                      ))
409                              ))
410             (ctx (fold (lambda (name value ctx)
411                          (set-value ctx name value))
412                        ctx arg-names (take/pad args arg-names-len (Tnull))))
413             (ctx (fold (lambda (name.value ctx)
414                          (let ((name (car name.value))
415                                (value (cdr name.value)))
416                          (set-value ctx name (or (alist-ref name kwargs) value))))
417                        ctx (merge-defaults defaults kwargs)))
418             (ctx (fold (lambda (name.value ctx)
419                          (let ((name (car name.value))
420                                (value (cdr name.value)))
421                            (set-value ctx name (or (alist-ref name kwargs) value))))
422                        ctx defaults))
423             (ctx (f ctx code)))
424        (pop-frame ctx))
425      ))
426  )
427
428
429(define (get-kvalue name kwargs #!key (defaults '()))
430  (or (alist-ref name kwargs) (alist-ref name defaults) (Tnull)))
431
432
433(define (op-safe value kwargs) value)
434
435
436(define (op-attr obj prop kwargs)
437  (cases tvalue obj
438         (Tobj (alst)
439               (cases tvalue prop
440                      (Tstr (prop) (or (alist-ref prop alst) (Tnull)))
441                      (else (error 'attr "operand type error" obj prop))))
442         (else (error 'attr "operand type error" obj prop))))
443
444
445(define (is-true x)
446  (cases tvalue x
447         (Tbool (x)  x)
448         (Tstr  (x)  (not (string-null? x)))
449         (Tint  (x)  (not (= x 0)))
450         (Tfloat (x) (not (= x 0.0)))
451         (Tlist (x)  (> (length x) 0))
452         (Tset  (x)  (> (length x) 0))
453         (Tobj  (x)  (> (length x) 0))
454         (Tnull ()   #f)
455         (Tfun (f)   (error 'is-true "operand type error" x))))
456
457
458(define (op-default value default kwargs)
459  (cases tvalue value
460         (Tnull () default)
461         (else value)))
462
463
464(define (op-negate x)
465  (cases tvalue x
466         (Tint (x)   (Tint (- x)))
467         (Tfloat (x) (Tfloat (- x)))
468         (else (error 'negate "operand type error" x))))
469
470
471
472(define (test-not x) (Tbool (not (is-true x))))
473
474
475(define (test-none ctx name)
476  (cases tvalue (get-value ctx name)
477         (Tnull () (Tbool #t))
478         (else (Tbool #f))))
479
480
481(define (test-defined ctx name)
482  (cases tvalue (get-value ctx name)
483         (Tnull () (Tbool #f))
484         (else (Tbool #t))))
485
486
487(define (test-undefined ctx name)
488  (cases tvalue (test-defined ctx name)
489         (Tbool (status) (Tbool (not status)))
490         (else (error 'test-undefined "invalid operand" name))))
491
492
493(define (test-obj-defined ctx objname propname)
494  (cases tvalue (get-value ctx objname)
495         (Tobj (alst) 
496               (Tbool (and (assoc propname alst) #t)))
497         (else (Tbool #f))))
498
499
500(define (test-obj-undefined ctx objname propname)
501  (cases tvalue (test-obj-defined ctx objname propname)
502         (Tbool (status) (Tbool (not status)))
503         (else (error 'test-obj-undefined "invalid operand" objname))))
504
505
506(define (test-escaped ctx)
507  (Tbool (member "safe" (tmpl-ctx-filter-table ctx))))
508
509
510(define (test-divisibleby num target kwargs)
511  (let ((n (unbox-int num))
512        (t (unbox-int target)))
513    (if (zero? n) 
514        (Tbool #f) 
515        (Tbool (zero? (modulo t n))))))
516         
517
518(define (test-even num kwargs)
519  (Tbool (zero? (modulo (unbox-int num) 2))))
520         
521
522(define (test-odd num kwargs)
523  (Tbool (= 1 (modulo (unbox-int num) 2))))
524
525         
526(define (test-iterable x kwargs)
527  (cases tvalue x
528         (Tlist (_) (Tbool #t))
529         (Tset (_)  (Tbool #t))
530         (else (Tbool #f))))
531
532         
533(define (test-lower x kwargs)
534  (cases tvalue x
535         (Tstr (str) (Tbool (string-every char-set:lower-case str)))
536         (else (Tbool #f))))
537
538         
539(define (test-upper x kwargs)
540  (cases tvalue x
541         (Tstr (str) (Tbool (string-every char-set:upper-case str)))
542         (else (Tbool #f))))
543
544         
545(define (test-number x kwargs)
546  (cases tvalue x
547         (Tint (i) (Tbool #t))
548         (Tfloat (f) (Tbool #t))
549         (else (Tbool #f))))
550
551         
552(define (test-string x kwargs)
553  (cases tvalue x
554         (Tstr (s) (Tbool #t))
555         (else (Tbool #f))))
556
557
558(define (test-sameas value target kwargs)
559  (cases tvalue value
560         (Tstr (x)
561               (cases tvalue target
562                      (Tstr (y) (Tbool (equal? x y)))
563                      (else (Tbool #f))))
564         (Tint (x)
565               (cases tvalue target
566                      (Tint (y) (Tbool (equal? x y)))
567                      (else (Tbool #f))))
568         (Tfloat (x)
569               (cases tvalue target
570                      (Tfloat (y) (Tbool (equal? x y)))
571                      (else (Tbool #f))))
572         (Tbool (x)
573               (cases tvalue target
574                      (Tbool (y) (Tbool (equal? x y)))
575                      (else (Tbool #f))))
576         (Tfun (x)
577               (cases tvalue target
578                      (Tfun (y) (Tbool (equal? x y)))
579                      (else (Tbool #f))))
580         (Tobj (x)
581               (cases tvalue target
582                      (Tobj (y) (Tbool (equal? x y)))
583                      (else (Tbool #f))))
584         (Tlist (x)
585               (cases tvalue target
586                      (Tlist (y) (Tbool (equal? x y)))
587                      (else (Tbool #f))))
588         (Tset (x)
589               (cases tvalue target
590                      (Tset (y) (Tbool (equal? x y)))
591                      (else (Tbool #f))))
592         (else (Tbool #f))
593         ))
594
595         
596(define (test-sequence target kwargs)
597  (test-iterable target kwargs))
598
599
600(define (op-plus left right)
601  (cases tvalue left
602         (Tint (x1)
603               (cases tvalue right
604                      (Tint (x2)   (Tint (+ x1 x2)))
605                      (Tfloat (x2) (Tfloat (+ x1 x2)))
606                      (Tstr (x2)   (Tstr (sprintf "~A~A" x1 x2)))
607                      (else (error 'plus "operand type error" left right))))
608         (Tfloat (x1)
609               (cases tvalue right
610                      (Tint (x2)   (Tfloat (+ x1 x2)))
611                      (Tfloat (x2) (Tfloat (+ x1 x2)))
612                      (Tstr (x2)   (Tstr (sprintf "~A~A" x1 x2)))
613                      (else (error 'plus "operand type error" left right))))
614         (Tstr (x1)
615               (cases tvalue right
616                      (Tstr (x2)   (Tstr (string-append x1 x2)))
617                      (Tint (x2)   (Tstr (sprintf "~A~A" x1 x2)))
618                      (Tfloat (x2)   (Tstr (sprintf "~A~A" x1 x2)))
619                      (else (error 'plus "operand type error" left right))))
620         
621         (else (error 'plus "operand type error" left right))
622         ))
623
624
625(define (op-minus left right)
626  (cases tvalue left
627         (Tint (x1)
628               (cases tvalue right
629                      (Tint (x2)   (Tint (- x1 x2)))
630                      (Tfloat (x2) (Tfloat (- x1 x2)))
631                      (else (error 'minus "operand type error" left right))))
632         (Tfloat (x1)
633               (cases tvalue right
634                      (Tint (x2)   (Tfloat (- x1 x2)))
635                      (Tfloat (x2) (Tfloat (- x1 x2)))
636                      (else (error 'minus "operand type error" left right))))
637         
638         (else (error 'minus "operand type error" left right))
639         ))
640
641
642(define (op-times left right)
643  (cases tvalue left
644         (Tint (x1)
645               (cases tvalue right
646                      (Tint (x2)   (Tint (* x1 x2)))
647                      (Tfloat (x2) (Tfloat (* x1 x2)))
648                      (else (error 'times "operand type error" left right))))
649         (Tfloat (x1)
650               (cases tvalue right
651                      (Tint (x2)   (Tfloat (* x1 x2)))
652                      (Tfloat (x2) (Tfloat (* x1 x2)))
653                      (else (error 'times "operand type error" left right))))
654         
655         (else (error 'times "operand type error" left right))
656         ))
657
658
659(define (op-power left right)
660  (letrec ((power1 (lambda (m n a)
661                     (if (<= n 0) a
662                         (if (zero? (modulo n 2))
663                             (power1 (* m m) (/ n 2) a)
664                             (power1 m (- n 1) (* m a)))))))
665  (cases tvalue left
666         (Tint (x1)
667               (cases tvalue right
668                      (Tint (x2)
669                            (Tfloat (power1 x1 x2 1.0)))
670                      (else (error 'power "operand type error" left right))))
671         (else (error 'power "operand type error" left right)))
672  ))
673
674
675(define (op-div left right)
676  (cases tvalue right
677         (Tint (x2)
678               (if (zero? x2)
679                   (error 'div "division by zero")
680                   (cases tvalue left
681                          (Tint (x1)
682                                (Tint (quotient x1 x2)))
683                          (Tfloat (x1)
684                                  (Tfloat (/ x1 x2)))
685                          (else
686                           (error 'div "operand type error" left right)))
687                   ))
688         (Tfloat (x2)
689                 (if (zero? x2)
690                     (error 'div "division by zero")
691                     (cases tvalue left
692                            (Tint (x1)
693                                  (Tfloat (/ x1 x2)))
694                            (Tfloat (x1)
695                                    (Tfloat (/ x1 x2)))
696                            (else
697                             (error 'div "operand type error" left right)))
698                     ))
699         (else
700          (error 'div "operand type error" left right))
701         ))
702
703
704(define (op-mod left right)
705  (cases tvalue right
706         (Tint (x2)
707               (if (zero? x2)
708                   (error 'mod "division by zero")
709                   (cases tvalue left
710                          (Tint (x1) (Tint (modulo x1 x2)))
711                          (else
712                           (error 'mod "operand type error" left right)))
713                   ))
714         (else
715          (error 'mod "operand type error" left right))
716         ))
717
718(define (op-round how value kwargs)
719  (cases tvalue value
720         (Tint (i) value)
721         (Tfloat (x)
722                 (let ((how (string->symbol (unbox-string how))))
723                   (case how
724                     ((floor)  (Tfloat (floor x)))
725                     ((ceil)   (Tfloat (ceiling x)))
726                     (else (error 'round "unknown rounding method" how)))))
727         (else (error 'round "operand type error" value))))
728                   
729
730(define (op-abs value kwargs)
731  (cases tvalue value
732         (Tint (x) (Tint (abs x)))
733         (else (error 'abs "operand type error" value))))
734
735
736(define (op-and left right)
737  (Tbool (and (is-true left) (is-true right))))
738
739
740(define (op-or left right)
741  (Tbool (or (is-true left) (is-true right))))
742
743
744(define (eq-eq left right)
745  (cases tvalue left
746         (Tint (x1)
747               (cases tvalue right
748                      (Tint (x2) (Tbool (= x1 x2)))
749                      (else (Tbool #f))))
750         (Tfloat (x1)
751                 (cases tvalue right
752                        (Tfloat (x2) (Tbool (= x1 x2)))
753                        (else (Tbool #f))))
754         (Tbool (x1)
755                 (cases tvalue right
756                        (Tbool (x2) (Tbool (equal? x1 x2)))
757                        (else (Tbool #f))))
758         (Tstr (x1)
759                 (cases tvalue right
760                        (Tstr (x2) 
761                              (Tbool (string=? x1 x2)))
762                        (else (Tbool #f))))
763         (Tlist (x1)
764                 (cases tvalue right
765                        (Tlist (x2) (list-same left right))
766                        (else (Tbool #f))))
767         (Tobj (x1)
768                 (cases tvalue right
769                        (Tobj (x2) (obj-same left right))
770                        (else (Tbool #f))))
771         (else (Tbool #f))
772         ))
773
774
775(define (list-same lst1 lst2)
776  (let ((l1 (unbox-list lst1))
777        (l2 (unbox-list lst2)))
778    (if (not (= (length l1) (length l2))) 
779        (Tbool #f)
780        (let ((result (every (compose unbox-bool eq-eq) l1 l2)))
781          (Tbool result)))
782    ))
783
784
785(define (obj-same obj1 obj2)
786  (let ((al1 (unbox-obj obj1))
787        (al2 (unbox-obj obj2)))
788    (if (not (= (length al1) (length al2))) 
789        (Tbool #f)
790        (let ((result (every (lambda (x) 
791                               (let ((v (alist-ref (car x) al2)))
792                                 (and v (unbox-bool (eq-eq v (cdr x)))))) al1)))
793          (Tbool result)))
794    ))
795
796
797(define (not-eq left right)
798  (cases tvalue left
799         (Tint (x1)
800               (cases tvalue right
801                      (Tint (x2) (Tbool (not (= x1 x2))))
802                      (else (Tbool #t))))
803         (Tfloat (x1)
804               (cases tvalue right
805                      (Tfloat (x2) (Tbool (not (= x1 x2))))
806                      (else (Tbool #t))))
807         (Tstr (x1)
808               (cases tvalue right
809                      (Tstr (x2) (Tbool (not (string=? x1 x2))))
810                      (else (Tbool #t))))
811         (else (Tbool #t))))
812
813
814(define (op-lt left right)
815  (cases tvalue left
816         (Tint (x1)
817               (cases tvalue right
818                      (Tint (x2) (Tbool (< x1 x2)))
819                      (else (error 'lt "operand type error" left right))))
820         (Tfloat (x1)
821               (cases tvalue right
822                      (Tfloat (x2) (Tbool (< x1 x2)))
823                      (else (error 'lt "operand type error" left right))))
824         (else (error 'lt "operand type error" left right))))
825
826
827(define (op-gt left right)
828  (cases tvalue left
829         (Tint (x1)
830               (cases tvalue right
831                      (Tint (x2) (Tbool (> x1 x2)))
832                      (else (error 'gt "operand type error" left right))))
833         (Tfloat (x1)
834               (cases tvalue right
835                      (Tfloat (x2) (Tbool (> x1 x2)))
836                      (else (error 'gt "operand type error" left right))))
837         (else (error 'gt "operand type error" left right))))
838
839
840(define (op-lteq left right)
841  (cases tvalue left
842         (Tint (x1)
843               (cases tvalue right
844                      (Tint (x2) (Tbool (<= x1 x2)))
845                      (else (error 'lteq "operand type error" left right))))
846         (Tfloat (x1)
847               (cases tvalue right
848                      (Tfloat (x2) (Tbool (<= x1 x2)))
849                      (else (error 'lteq "operand type error" left right))))
850         (else (error 'lteq "operand type error" left right))))
851
852
853(define (op-gteq left right)
854  (cases tvalue left
855         (Tint (x1)
856               (cases tvalue right
857                      (Tint (x2) (Tbool (>= x1 x2)))
858                      (else (error 'gteq "operand type error" left right))))
859         (Tfloat (x1)
860               (cases tvalue right
861                      (Tfloat (x2) (Tbool (>= x1 x2)))
862                      (else (error 'gteq "operand type error" left right))))
863         (else (error 'gteq "operand type error" left right))))
864
865
866(define (op-in left right)
867  (cases tvalue right
868         (Tlist (lst)
869                (Tbool (any (compose unbox-bool (lambda (x) (eq-eq x left))) lst)))
870         (else (Tbool #f))))
871
872
873
874(define (op-upper x kwargs)
875  (cases tvalue x
876         (Tstr (str) (Tstr (string-upcase str)))
877         (else  (Tstr (sprintf "~A" x)))))
878
879
880(define (op-lower x kwargs)
881  (cases tvalue x
882         (Tstr (str) (Tstr (string-downcase str)))
883         (else  (Tstr (sprintf "~A" x)))))
884
885
886(define (op-capitalize value kwargs)
887  (Tstr (string-titlecase (unbox-string value))))
888
889
890(define (op-toint x kwargs)
891  (cases tvalue x
892         (Tint (_)  x)
893         (Tfloat (v)  (Tint (inexact->exact (round v))))
894         (else (error 'toint "operand type error" x))))
895
896
897(define (op-tofloat x kwargs)
898  (cases tvalue x
899         (Tfloat (_)  x)
900         (Tint (v)  (Tfloat (exact->inexact v)))
901         (else (error 'tofloat "operand type error" x))))
902
903
904(define (op-join join-str lst kwargs)
905  (let ((str (unbox-string join-str)))
906    (cases tvalue lst
907           (Tlist (lst)
908                  (Tstr (string-concatenate (intersperse (map ->string lst) str))))
909           (Tset (lst)
910                 (Tstr (string-concatenate (intersperse (map ->string lst) str))))
911           (else (error 'join "operand type error" join-str lst)))))
912
913
914(define (op-split pat text kwargs)
915  (let ((pat (unbox-string pat))
916        (text (unbox-string text)))
917    (let ((lst (irregex-split (string->irregex pat) text)))
918      (Tlist (map Tstr lst)))))
919
920
921(define (op-substring base count str kwargs)
922  (let ((base  (unbox-int base))
923        (count (unbox-int count))
924        (str   (cases tvalue str
925                      (Tstr (str) str)
926                      (Tnull ()  "")
927                      (else (error 'substring "operand type error" str)))))
928    (if (string-null? str) 
929        (Tstr "")
930        (Tstr (substring str base (+ base count))))
931    ))
932       
933
934(define (op-truncate len str kwargs)
935  (let (
936        (len (unbox-int len))
937        (str (unbox-string str))
938        )
939    (if (string-null? str) 
940        (Tstr "")
941        (Tstr (substring str 0 len)))
942    ))
943   
944
945(define (op-replace src dst str kwargs)
946  (let (
947        (src (unbox-string src))
948        (dst (unbox-string dst))
949        (str (unbox-string str))
950        )
951    (Tstr (irregex-replace/all (string->irregex src) str dst))
952    ))
953
954
955(define (op-trim str kwargs)
956  (let ((str (unbox-string str)))
957    (Tstr (string-trim-both str char-set:whitespace))))
958
959
960; procedure: string->goodHTML STRING
961; Given a string, check to make sure it does not contain characters
962; such as '<' or '&' that require encoding. Return either the original
963; string, or a list of string fragments with special characters
964; replaced by appropriate character entities.
965
966(define string->goodHTML
967  (make-char-quotator
968   '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;"))))
969
970
971(define (op-escape-html str kwargs)
972  (let ((str (unbox-string str)))
973    (let ((res (string->goodHTML str)))
974      (Tstr (if (string? res) res (string-concatenate res))))))
975
976(define url-pat
977  (string->irregex "((http|ftp|https):\\/\\/[\\w\\-_]+(\\.[\\w\\-_]+)+([\\w\\-\\.,@?^=%&amp;:/~\\+#]*[\\w\\-\\@?^=%&amp;/~\\+#])?)"))
978
979(define (op-urlize text kwargs)
980  (let ((str (unbox-string text)))
981    (Tstr (irregex-replace/all url-pat str
982                               "<a href='" 1 "'>" 1 "</a>"))))
983
984
985(define (op-title text kwargs)
986  (let ((str (unbox-string text)))
987    (Tstr (string-titlecase str))))
988
989
990(define (op-striptags text kwargs)
991  (let* ((str (unbox-string text))
992         (pat (string->irregex "<\\/?[^>]+>")))
993    (Tstr (irregex-replace/all pat str ""))))
994
995(define whitespace-pat (sre->irregex '($ (+ whitespace))))
996
997(define (op-wordcount text kwargs)
998  (let ((str (unbox-string text)))
999    (Tint (length (irregex-split whitespace-pat str)))))
1000
1001
1002(define (op-strlen x kwargs)
1003  (cases tvalue x
1004         (Tstr (str) (Tint (string-length str)))
1005         (else (error 'strlen "operand type error" x))))
1006
1007
1008(define (op-length x kwargs)
1009  (cases tvalue x
1010         (Tlist (lst) (Tint (length lst)))
1011         (Tset (lst) (Tint (length lst)))
1012         (Tstr (str) (Tint (string-length str)))
1013         (else (error 'length "operand type error" x))))
1014
1015
1016(define (op-reverse lst kwargs)
1017  (let ((lst (unbox-list lst)))
1018    (Tlist (reverse lst))))
1019
1020(define (op-append x y kwargs)
1021  (let ((xlst (unbox-list x))
1022        (ylst (unbox-list y)))
1023    (Tlist (append xlst ylst))))
1024
1025(define (op-cons x y kwargs)
1026  (let ((ylst (unbox-list y)))
1027    (Tlist (cons x ylst))))
1028
1029
1030(define (op-last lst kwargs)
1031  (let ((lst (unbox-list lst)))
1032    (last lst)))
1033
1034(define (op-first lst kwargs)
1035  (let ((lst (unbox-list lst)))
1036    (first lst)))
1037
1038
1039(define (op-list value kwargs)
1040  (cases tvalue value
1041         (Tlist (lst) value)
1042         (Tset (lst)  (Tlist lst))
1043         (Tstr (str)
1044               (let ((len (string-length str)))
1045                 (let iter ((ret '()) (i len))
1046                   (if (zero? i)
1047                       (Tlist ret)
1048                       (let ((s1 (Tstr (substring str (- i 1) i))))
1049                         (iter (cons s1 ret) (- i 1)))
1050                       ))
1051                 ))
1052         (else (error 'list "operand type error" value))
1053         ))
1054
1055
1056(define (op-set value kwargs)
1057  (cases tvalue value
1058         (Tlist (lst) value)
1059         (Tset (lst)  (Tlist lst))
1060         (Tstr (str)
1061               (let ((len (string-length str)))
1062                 (let iter ((ret '()) (i len))
1063                   (if (zero? i)
1064                       (Tlist ret)
1065                       (let ((s1 (Tstr (substring str (- i 1) i))))
1066                         (iter (cons s1 ret) (- i 1)))
1067                       ))
1068                 ))
1069         (else (error 'list "operand type error" value))
1070         ))
1071
1072
1073(define (op-slice len value kwargs #!key (defaults `((fill_with . ,(Tnull)))))
1074  (op-batch len (op-list value '()) kwargs))
1075
1076
1077(define (op-sublist base count lst kwargs)
1078  (let ((base (unbox-int base))
1079        (lst  (unbox-list lst)))
1080    (cases tvalue count
1081           (Tint (count)
1082                 (Tlist (take (drop lst base) count)))
1083           (Tnull ()
1084                  (Tlist (drop lst base)))
1085           (else (error 'sublist "operand type error" count)))
1086    ))
1087
1088
1089(define (op-group-by base lst kwargs)
1090  (let ((base (unbox-int base))
1091        (lst  (unbox-list lst)))
1092    (let recur ((lst lst) (groups '()))
1093      (if (< (length lst) base)
1094          (Tlist (reverse (cons (Tlist lst) groups)))
1095          (recur (drop lst base) 
1096                 (cons (Tlist (take lst base)) groups))
1097          ))
1098    ))
1099
1100
1101(define (op-range start stop kwargs)
1102  (let ((start (unbox-int start))
1103        (stop (unbox-int stop)))
1104    (if (= start stop)
1105        (Tlist (list (Tint start)))
1106        (let ((is-end? (lambda (i) (if (< start stop) (> i stop) (< i stop))))
1107              (next (lambda (i) (if (< start stop) (+ i 1) (- i 1)))))
1108          (let iter ((ret '()) (i start))
1109            (if (is-end? i) 
1110                (Tlist (reverse ret))
1111                (iter (cons (Tint i) ret) (next i))))
1112          ))
1113    ))
1114
1115
1116(define (op-batch count value kwargs #!key (defaults `((fill_with . ,(Tnull)))))
1117  (let ((slice-count (unbox-int count))
1118        (lst (unbox-list value)))
1119    (let ((fill-value 
1120           (let ((v (get-kvalue 'fill_with kwargs defaults)))
1121             (cases tvalue v
1122                    (Tnull () #f)
1123                    (else v)))))
1124      (let batch ((ret '()) 
1125                  (left-count (length lst))
1126                  (rest lst))
1127        (cond ((> left-count slice-count)
1128               (batch (cons (Tlist (take rest slice-count)) ret)
1129                         (- left-count slice-count)
1130                         (drop rest slice-count)))
1131              ((> left-count 0)
1132               (batch (cons (Tlist (filter identity (take/pad rest slice-count fill-value))) ret) 0 '()))
1133              (else (Tlist (reverse ret)))
1134              ))
1135      ))
1136  )
1137
1138
1139(define (op-sort lst kwargs)
1140  (let ((lst (unbox-list lst)))
1141    (cases tvalue (car lst)
1142           (Tstr (s)
1143                 (Tlist (map Tstr (sort (cons s (map unbox-string (cdr lst))) string<))
1144                        ))
1145           (Tint (i)
1146                 (Tlist (map Tint (sort (cons i (map unbox-int (cdr lst))) <))))
1147           (Tfloat (i)
1148                   (Tlist (map Tfloat (sort (cons i (map unbox-float (cdr lst))) <))))
1149           (else "operand type error" lst))
1150           ))
1151                 
1152
1153(define (op-dictsort val kwargs 
1154                     #!key (defaults  `((case_sensitive . ,(Tbool #t))
1155                                        (by             . ,(Tstr "key")))))
1156
1157  (let ((cs (cases tvalue (get-kvalue 'case_sensitive kwargs defaults)
1158                   (Tbool (v) v)
1159                   (else (error 'dictsort "operand type error")))))
1160
1161    (cases tvalue val
1162           (Tobj (alst)
1163                 (Tobj (if cs 
1164                           (sort alst 
1165                                 (lambda (a b) (string< (symbol->string (car a))
1166                                                        (symbol->string (car b)))))
1167                           (sort alst 
1168                                 (lambda (a b) (string-ci< (symbol->string (car a))
1169                                                           (symbol->string (car b)))))
1170                                 )))
1171           (else val))
1172))
1173
1174
1175(define (op-dict val kwargs) 
1176  (let ((alst (unbox-obj val)))
1177    (Tlist (map (lambda (key.val)
1178                  (let ((name (car key.val))
1179                        (val (cdr key.val)))
1180                    (Tobj `((name . ,(Tstr (->string name)))
1181                            (value . ,val)))))
1182                alst))
1183    ))
1184                       
1185
1186(define (func-arg0 f) 
1187  (Tfun (lambda (args kwargs) 
1188          (f kwargs))))
1189
1190(define (func-arg1 f) 
1191  (Tfun (lambda (args kwargs) 
1192          (if (= 1 (length args))
1193              (f (car args) kwargs)
1194              (Tnull)))
1195        ))
1196
1197
1198(define (func-arg2 f) 
1199  (Tfun (lambda (args kwargs) 
1200          (let ((len (length args)))
1201            (cond ((= len 2) 
1202                   (f (car args) (cadr args) kwargs))
1203                  ((= len 1) 
1204                   (let ((arg1 (car args)))
1205                     (func-arg1 (lambda (arg2 kwargs) (f arg1 arg2 kwargs)))
1206                     ))
1207                  (else  (Tnull)))
1208            ))
1209        ))
1210
1211(define (func-arg3 f) 
1212  (Tfun (lambda (args kwargs) 
1213          (let ((len (length args)))
1214            (cond ((= len 3) (f (car args) (cadr args) (caddr args) kwargs))
1215                  ((= len 2) 
1216                   (let ((arg1 (car args)) (arg2 (cadr args)))
1217                     (func-arg1 (lambda (arg3 kwargs) (f arg1 arg2 arg3 kwargs)))
1218                     ))
1219                  ((= len 1) 
1220                   (let ((arg1 (car args)))
1221                     (func-arg2 (lambda (arg2 kwargs) (f arg1 arg2 kwargs)))))
1222                  (else  (Tnull)))
1223            ))
1224        ))
1225
Note: See TracBrowser for help on using the repository browser.