44dd4acb44
This adds the option to generate random terms that satisfy judgment-forms and metafunctions. Currently functionality does not include: - patterns/terms using: ellipses, in-hole/hole and relatives, side-conditions, unquotes - define-relation - redex-check integration
40 lines
1.5 KiB
Racket
40 lines
1.5 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base
|
|
syntax/stx)
|
|
"match-a-pattern.rkt"
|
|
racket/match)
|
|
|
|
(provide extract-clauses
|
|
extracted-clauses->fns)
|
|
|
|
(define-for-syntax extracted-conditions #f)
|
|
(define-syntax (extract-clauses stx)
|
|
(syntax-case stx (match-a-pattern)
|
|
[(_ (match-a-pattern #:allow-else p clauses ...))
|
|
(begin
|
|
(set! extracted-conditions
|
|
(cons #'p
|
|
(filter
|
|
values
|
|
(map
|
|
(λ (clause)
|
|
(syntax-case clause (else)
|
|
[[cond #f] #f]
|
|
[[`(name id pat) if-part]
|
|
[eq? 'name (syntax-e #'name)]
|
|
#f] ;; skip this here, want bound variant for pat* - added in pat-unify
|
|
[[else exp ...] #f] ;; skip the cstr test; that's added elsewhere
|
|
[[cond not-false ...] #'cond]))
|
|
(syntax->list #'(clauses ...))))))
|
|
(stx-car (stx-cdr stx)))]))
|
|
|
|
(define-syntax (extracted-clauses->fns stx)
|
|
(unless extracted-conditions
|
|
(raise-syntax-error #f "no pats extracted"))
|
|
(with-syntax ([(p condition ...) extracted-conditions]
|
|
[(name ...) (map (λ (x) (string->symbol (format "~s" (syntax->datum x))))
|
|
(cdr extracted-conditions))])
|
|
#`(list
|
|
(let ([name (λ (p) (match p [condition #t] [else #f]))])
|
|
name) ...)))
|