[private] checked extra constraints

bennn · Mar 8, 2016 · f6b4f8b · f6b4f8b
1 parent c2a7992
commit f6b4f8b
Show file tree

Hide file tree

Showing 4 changed files with 57 additions and 69 deletions.
diff --git a/ipoe/private/poem/form.rkt b/ipoe/private/poem/form.rkt
@@ -107,7 +107,7 @@
       ;; Keyword for extra constraints
       (define c (read-keyword-value in (lambda (x) #t)
                                     #:kw '#:constraint #:src err-loc))
-      (define c+ (validator? c))
+      (define c+ (valid-constraint? c))
       (unless c+ (user-error err-loc (format "Expected a constraint expression, but got '~a'" c)))
       (loop name rhyme-scheme syllables description (cons c+ constraint*))]
      ;; -- Check for unknown symbols
@@ -128,7 +128,7 @@
       (loop name rhyme-scheme syllables d constraint*)]
      [x
       ;; Try parsing `x` as a validator, otherwise fail because it's undefined data
-      (define c (validator? x))
+      (define c (valid-constraint? x))
       (cond
        [c
         (loop name rhyme-scheme syllables description (cons c constraint*))]
@@ -218,20 +218,19 @@
           ;; -- Done! Return anything needed to make testing easy
           (list P L option*)))))))
 
-;; Parse a syntax object as a function in a restricted namespace.
-;; If ok, return the original syntax object.
-;; TODO make sure these are good error messages
-;; TODO raise error if compiles without *poem* set?
-;; TODO rename, should be constraint? or something
-;; (: validator? (-> Syntax Syntax))
-(define (validator? expr)
-  ;; -- Just compile, name sure doesn't error
-  ;(define evaluated
-  ;  (with-constraint-namespace
-  ;    (eval expr (current-namespace))))
-  expr)
-
-;; TODO namespace should be very restricted
+;; A constraint is an extra thunk run after the poem is processed,
+;;  and assumed to evaluate to #f if some part of the poem is malformed.
+;; (: valid-constraint? (-> Syntax (U #f Syntax)))
+(define (valid-constraint? raw-expr)
+  (define expr
+    (with-handlers ([exn:fail? (lambda (e) #f)])
+      (with-constraint-namespace
+        (eval (compile raw-expr)))))
+  (and expr
+       (procedure? expr)
+       (procedure-arity-includes? expr 0)
+       expr))
+
 (define-syntax-rule (with-constraint-namespace e)
   (parameterize ([current-namespace (make-base-namespace)])
     (namespace-require 'ipoe/private/poem)
@@ -264,15 +263,6 @@
     (only-in racket/string string-split)
   )
 
-;  ;; -- helper function, convert a syntactic function into a lambda
-;  (define (eval-extra-validator F)
-;    (stx->validator (form-extra-validator F)))
-;
-;  (define (stx->validator stx)
-;    (parameterize ([current-namespace (make-base-namespace)])
-;      (namespace-require 'ipoe/sugar)
-;      (eval stx (current-namespace))))
-
   ;; -- check-duplicate
   ;; Always void if first arg is #f
   (check-equal? (check-duplicate #f #:new-val 'a #:src 'b #:msg 'c)
@@ -318,20 +308,20 @@
   (let* ([ps (test-make-form (string-append
                                      "#:name has-extra "
                                      "#:rhyme-scheme ((1 2 3) (A B (C . 3))) "
-                                     "#:constraint #t"))]
+                                     "#:constraint (lambda () #t)"))]
          [c* (form-constraint* ps)])
     (check-true (form? ps))
     (check-equal? (form-name ps) 'has-extra)
     (check-equal? (form-rhyme-scheme ps) '((1 2 3) (A B (C . 3))))
     (check-true (list? c*))
     (check-equal? (length c*) 1)
-    (check-true (with-constraint-namespace (eval (car c*)))))
+    (check-true ((with-constraint-namespace (eval (car c*))))))
 
-  (let* ([ps (test-make-form "name (((Schema . 42))) #t")]
+  (let* ([ps (test-make-form "name (((Schema . 42))) (lambda () #t)")]
          [c* (form-constraint* ps)])
     (check-true (form? ps))
     (check-equal? (form-name ps) 'name)
-    (check-true (with-constraint-namespace (eval (car c*)))))
+    (check-true ((with-constraint-namespace (eval (car c*))))))
 
   ;; -- read-keyword-value
   (let* ([src 'rkvtest]
@@ -463,34 +453,30 @@
        ['yes == #f]
        ['no == #f])))
 
-;  ;; -- validator?
-;  (check-false* validator?
-;   ['#f]
-;   [#f]
-;   [''(1 2 3)]
-;   ['(+ 1 1)]
-;   ["hello"])
-;
-;  (check-true* (lambda (v) (and (validator? v) #t))
-;   ['(lambda (x) #t)]
-;   ['(lambda (x) #f)]
-;   ['(lambda (x) (< 5 (length x)))])
-;
-;  ;; --- test a "good" validator function
-;  ;;     2015-08-19: removed contract checks
-;  (let* ([v-stx (validator? '(lambda (x) (null? x)))]
-;         [v (stx->validator v-stx)])
-;    (check-true (v '()))
-;    (check-false (v '(())))
-;    ; (check-exn exn:fail:contract? (lambda () (v 1)))
-;  )
-;  ;; 2015-08-27: Commented validator tests until we bring back the contracts
-;  ; ;; --- invalid validator: wrong domain
-;  ; (check-exn exn:fail:contract?
-;  ;            (lambda () (validator? '(lambda (x y) x))))
-;  ; ;; --- invalid validator: wrong codomain
-;  ; (let ([v (validator? '(lambda (x) x))])
-;  ;   (check-exn exn:fail:contract?
-;  ;              (lambda () (v '()))))
+  ;; -- valid-constraint?
+  (check-false* valid-constraint?
+   ['#f]
+   [#f]
+   [''(1 2 3)]
+   ['(+ 1 1)]
+   ['(lambda (x) x)]
+   ['(lambda (x y #:z z) #t)]
+   ["hello"])
+
+  (check-true* (lambda (v) (and (valid-constraint? v) #t))
+   ['(lambda () #t)]
+   ['(lambda () #f)]
+   ['(lambda () (< 5 (length x)))])
+
+  ;; --- test a "good" validator function
+  (let ()
+    (let ([c (valid-constraint? '(lambda () #t))])
+      (check-true (if c #t #f))
+      (check-true (procedure? c))
+      (check-true (c)))
+    (let ([c (valid-constraint? '(lambda () (*poem*)))])
+      (check-true (if c #t #f))
+      (check-true (procedure? c))
+      (check-false (c))))
 )
 
diff --git a/ipoe/rondelet/lang/reader.rkt b/ipoe/rondelet/lang/reader.rkt
@@ -8,9 +8,9 @@
                  (B . 8)
                  (B . 8)
                  (A . 4)))
-#:constraint
+#:constraint (lambda ()
   (let ([S (stanza 0)])
     (line=? (line 0 S)
             (line 2 S)
-            (line 6 S)))
+            (line 6 S))))
 
diff --git a/ipoe/sestina/lang/reader.rkt b/ipoe/sestina/lang/reader.rkt
@@ -16,6 +16,7 @@
                 [* * * * * *]
                 [* * *]}
 #:constraint ;; Really, this is many constraints. Hence 'apply append'
+ (lambda ()
  (apply append
    ;; Word constraints (after position 0, want +1, +3, +4, +1, +2)
    (for/list ([l+s* (in-list '(((0 . 0) (1 . 1) (3 . 2) (4 . 3) (2 . 4) (5 . 5))
@@ -26,12 +27,13 @@
                                ((5 . 0) (0 . 1) (1 . 2) (3 . 3) (4 . 4) (2 . 5))))])
      (define (get-word l+s)
        (last-word (line (car l+s) (stanza (cdr l+s)))))
-     (apply word=? (map get-word l+s*))))
+     (apply word=? (map get-word l+s*)))))
 
 #:constraint
   ;; Tercet constraints.
   ;; A specific pair of words must appear in each line the second
   ;;  in each pair must be the last word in the line.
+ (lambda ()
   (apply append
    (for/list ([ln (stanza->line* (stanza -1))]
               [fw (in-list '(1 3 5))]
@@ -40,7 +42,7 @@
      (append
        (if (quirk? cw?) (list cw?) '())
        (word=? (last-word ln)
-         (last-word (line lw (stanza 0)))))))
+         (last-word (line lw (stanza 0))))))))
 
 ;; The examples I've seen only use the 6 words in the last line.
 ;; There's not as strict about the order, but

diff --git a/ipoe/villanelle/lang/reader.rkt b/ipoe/villanelle/lang/reader.rkt
@@ -10,13 +10,13 @@
 #:syllables 10
 ;; All R1 lines must be equal,
 ;; and all R2 lines must be equal
-#:constraint
+#:constraint (lambda ()
   (line=? (line 0 (stanza 0))
           (line 2 (stanza 1))
           (line 2 (stanza 3))
-          (line 2 (stanza 5)))
-#:constraint
-(line=? (line 2 (stanza 0))
-        (line 2 (stanza 2))
-        (line 2 (stanza 4))
-        (line 3 (stanza 5)))
+          (line 2 (stanza 5))))
+#:constraint (lambda ()
+  (line=? (line 2 (stanza 0))
+          (line 2 (stanza 2))
+          (line 2 (stanza 4))
+          (line 3 (stanza 5))))