src/thales/seal.scm

   1 (define-module (thales seal)
   2     #:replace (sealed))
   3 (use-modules (ice-9 match))
   4 (use-modules (ice-9 pretty-print))
   5 (use-modules (srfi srfi-1))
   6 (use-modules (srfi srfi-26))
   7
   8 (define-syntax push
   9     (syntax-rules ()
  10         ((_ val list)
  11          (set! list (cons val list)))))
  12
  13 (define (current-module-name)
  14     (module-name (current-module)))
  15 (define (current-module-load-filename)
  16     (string-join (map symbol->string (current-module-name)) "/"))
  17
  18 (define (seal:pretty-print obj)
  19     "Output object on stderr if env THALES_SEAL is set.
  20
  21 This function is used to output valid Guile program to check seals."
  22     (when (getenv "THALES_SEAL")
  23         (format (current-error-port) "~a"
  24                 (with-output-to-string [cute pretty-print obj]))))
  25
  26 (define (in-module?)
  27     (module-filename (current-module)))
  28
  29 (define load-self-once
  30     (let ((already-loaded '()))
  31         (lambda ()
  32             "Load current module, unless it was not already
  33 loaded with this function."
  34             (unless (member (current-module) already-loaded)
  35                 (seal:pretty-print `(use-modules ,(current-module-name)))
  36                 (seal:pretty-print `(use-modules (thales seal)))
  37                 (when (in-module?)
  38                     (primitive-load-path (current-module-load-filename)))
  39                 (push (current-module) already-loaded)))))
  40
  41 (define (error:broken-seal form expect result)
  42     (format #t "\nCompilation aborted: seal broken when evaluating\n")
  43     (pretty-print form)
  44     (format #t "\nExpect:\n")
  45     (pretty-print expect)
  46     (format #t "\nActual:\n")
  47     (pretty-print result)
  48     (exit 1))
  49
  50 (define-syntax call-and-catch
  51     (syntax-rules ()
  52         ((_ <form> <on-values> <on-throw>)
  53          (let ((throw-handler-called #f))
  54              (call-with-values [cute catch #t
  55                                        (lambda () <form>)
  56                                        (lambda args
  57                                            (apply <on-throw> args)
  58                                            (set! throw-handler-called #t))]
  59                  (lambda args
  60                      (unless throw-handler-called
  61                              (apply <on-values> args))))))))
  62
  63 (define-syntax seal-clause-expect-values
  64     (syntax-rules ()
  65         ([_ <form> (<val> ...)]
  66          (let* ((expected (list 'values <val> ...))
  67                 (error:handle [cute error:broken-seal '<form> expected <>]))
  68              (call-and-catch <form>
  69                  (lambda args
  70                      (unless (equal? args (cdr expected))
  71                          (error:handle (cons 'values args))))
  72                  (lambda throw-args
  73                      (error:handle (cons 'throw throw-args))))))))
  74
  75 (define-syntax seal-clause-expect-throw
  76     (syntax-rules ()
  77         ([_ <form> (<val> ...)]
  78          (let* ((expected (list 'throw <val> ...))
  79                 (error:handle [cute error:broken-seal '<form>
  80                                     (append expected '(....)) <>]))
  81              (call-and-catch <form>
  82                  (lambda args
  83                      (error:handle (cons 'values args)))
  84                  (lambda throw-args
  85                      (define (throw-args-match expected-args actual-args)
  86                          (and (<= (length expected-args) (length actual-args))
  87                               (every equal? expected-args actual-args)))
  88                      (unless (throw-args-match (cdr expected) throw-args)
  89                          (error:handle (cons 'throw throw-args)))))))))
  90
  91 (define-syntax seal-clause
  92     (syntax-rules (=> !--> *** *+* *!* *#*)
  93         ([_ f <args> ... *** <val>]
  94          (seal-clause-expect-values (f <args> ...) (<val>)))
  95         ([_ f <args> ... *+* <val>]
  96          (seal-clause-expect-values (f <args> ...) ('<val>)))
  97         ([_ f <form> => <val> ...]
  98          (seal-clause-expect-values <form> (<val> ...)))
  99         ([_ f <form> !--> <val> ...]
 100          (seal-clause-expect-throw <form> (<val> ...)))
 101         ([_ f <args> ... *!* <val>]
 102          (seal-clause-expect-throw (f <args> ...) ('<val>)))
 103         ([_ f <form>]
 104          (seal-clause-expect-values <form> (#t)))
 105         ([_ f <args> ... *#* <val>]
 106          (seal-clause-expect-values (syntax->datum (f <args> ...)) ('<val>)))))
 107
 108 (define-syntax sealed
 109     (lambda (env)
 110         (syntax-case env ()
 111             ((_ f (obj ...) ...)
 112              (with-syntax ((& (datum->syntax env '&)))
 113                  #'(eval-when (compile)
 114                        (load-self-once)
 115                        (when (module-variable (module-public-interface
 116                                                (current-module))
 117                                               'f)
 118                            (seal:pretty-print `(sealed ,'f (obj ...) ...)))
 119                        (let ((& f))
 120                            (format #t "Checking seals with & = ~a... " 'f)
 121                            (seal-clause f obj ...) ...
 122                            (format #t "ok\n"))))))))