r7rs-fuzzer.rkt

#lang racket/base

(require xsmith
         racr
         xsmith/racr-convenience
         racket/pretty
         racket/random
         racket/list
         racket/class
         racket/string
         racket/port)

;; XSMITH-based fuzzer for R7RS - following Rattle's
;; support for R7RS

(define-spec-component r7rs-core)

(add-to-grammar
 r7rs-core

 [Expression #f ()
             #:prop may-be-generated #f]

 [Let Expression ([definitions : Definition * = 0 #;(random 3)]
                  [body : DefinitionContext])
      #:prop strict-child-order? #t]

 [LiteralBool Expression ([v = (even? (random 2))])]
 [LiteralNumber Expression (v) #:prop may-be-generated #f]
 [LiteralInt LiteralNumber ()]
 
 [Not Expression ([Expression])]

 [If Expression ([test : Expression] [then : Expression] [else : Expression])
     #:prop strict-child-order? #t]
 
 )

(add-prop r7rs-core fresh
          [LiteralInt (hash 'v (* (random 1000000)
                                  (if (equal? 0 (random 2)) -1 1)))])

;; helper for render-node-info
(define (->se sym . children-refs)
  (lambda (n)
    `(,sym ,@(map (lambda (x) (render-node (ast-child x n)))
                  children-refs))))

(define (->se* sym children-ref)
  (lambda (n)
    `(,sym ,@(map (lambda (x) (render-node x))
                  (ast-children (ast-child children-ref n))))))

(add-prop
 r7rs-core
 render-node-info

 [Let (lambda (n) `(let (,@(map (lambda (d) `(,(string->symbol (ast-child 'name d))
                                              ,(render-node (ast-child 'Expression d))))
                                (ast-children (ast-child 'definitions n))))
                     ,@(render-node (ast-child 'body n))))]

 [LiteralBool (lambda (n) (ast-child 'v n))]
 [LiteralNumber (lambda (n) (ast-child 'v n))])

(add-prop
 r7rs-core
 render-hole-info
 [#f (lambda (h) (list 'HOLE (ast-node-type h)))])

;; Types
(type-variable-subtype-default #t)
(define number (base-type 'number))
(define int (base-type 'int number))
(define bool (base-type 'bool))

(define (type-thunks-for-concretization)
  (list (lambda () int)
        (lambda () bool)))

(define no-child-types (λ (n t) (hash)))
(define (fresh-concrete-var-type)
  (concretize-type (fresh-type-variable)))

(add-prop
 r7rs-core
 type-info

 [Let [(fresh-type-variable) (lambda (n t)
                               (hash 'body t
                                     'definitions (lambda (c) (fresh-type-variable))))]]

 [LiteralBool [bool (no-child-types)]]
 [LiteralInt [int (no-child-types)]]

 [If [(fresh-type-variable)
      (lambda (n t)
        (hash 'test bool 'then t 'else t))]])

(assemble-spec-components
 r7rs
 r7rs-core)

(define (r7rs-generate)
  (parameterize ([current-xsmith-type-constructor-thunks
                  (type-thunks-for-concretization)])
    (r7rs-generate-ast 'Expression)))

(define (r7rs-format-render forms)
  (with-output-to-string
    (lambda ()
      (define (pp x)
        (pretty-print x (current-output-port) 1))
      (for ([form forms])
        (pp form)))))

(module+ main
  (xsmith-command-line
   r7rs-generate
   #:format-render r7rs-format-render))