gdritter repos when-computer / master generator / libs.scm
master

Tree @master (Download .tar.gz)

libs.scm @master — raw · history · blame 

 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
;; some library stuff

(define (++ . args) (apply string-append args))

(define (as-string s)
  (if (symbol? s) (symbol->string s) s))

(define (intercalate x xs)
  (define (go ls)
    (cond ((null? ls) '())
          ((null? (cdr ls)) ls)
          (else
           (cons (car ls) (cons x (go (cdr ls)))))))
  (apply ++ (go xs)))

(define (scss->css scss)
  (define (mk-selector selector)
    (cond ((symbol? selector)
           (symbol->string selector))
          ((and (list? selector)
                (eq? (car selector) '=)
                (eq? (cadr selector) 'class))
           (++ "." (symbol->string (caddr selector))))
          ((and (list? selector)
                (eq? (car selector) '=)
                (eq? (cadr selector) 'id))
           (++ "#" (symbol->string (caddr selector))))
          ((and (list? selector)
                (eq? (car selector) '//))
           (intercalate " " (map mk-selector (cdr selector))))
          ((and (list? selector)
                (eq? (car selector) '&&))
           (intercalate "," (map mk-selector (cdr selector))))
          (else "...")))
  (define (mk-line line)
    (++ "  " (as-string (car line)) ": " (as-string (cadr line)) ";\n"))
  (define (mk-clause clause)
    (++
     (mk-selector (car clause))
     " {\n"
     (apply ++ (map mk-line (cdr clause)))
     "}\n"))
  (apply ++ (map mk-clause scss)))

(define (cadr? sexp)
  (if (or (null? sexp)
          (null? (cdr sexp))
          (not (list? (cadr sexp))))
      #f (cadr sexp)))

(define (serialize-sxml sxml)
  (define (mk-prop prop)
    (if (null? (cdr prop))
        (++ " " (as-string (car prop)))
        (let ((key (as-string (car prop))) (val (as-string (cadr prop))))
          (++ " " key "="
              (if (string? val) (++ "\"" val "\"") (as-string val))))))
  (cond ((null? sxml) "")
        ((string? sxml) sxml)
        ((symbol? sxml) (symbol->string sxml))
        ((not (symbol? (car sxml)))
         (apply string-append (map serialize-sxml sxml)))
        (else
         (let ((tag (symbol->string (car sxml)))
               (props (if (and (cadr? sxml) (eq? (caadr sxml) '@))
                          (cdadr sxml) '()))
               (vals (if (and (cadr? sxml) (eq? (caadr sxml) '@))
                         (cddr sxml) (cdr sxml))))
           (if (null? vals)
               (++ "<"
                   tag
                   (apply ++ (map mk-prop props))
                   " />")
               (++ "<"
                   tag
                   (apply ++ (map mk-prop props))
                   ">"
                   (apply ++ (map serialize-sxml vals))
                   "</"
                   tag
                   ">"))))))

(define (sxml->html5 sxml)
  (++ "<!DOCTYPE html>" (serialize-sxml sxml)))