#lang racket/base (require "matcher.rkt" "term.rkt" "fresh.rkt" "error.rkt" "search.rkt" racket/trace racket/stxparam "term-fn.rkt" "rewrite-side-conditions.rkt" (prefix-in pu: "pat-unify.rkt")) (require (for-syntax "rewrite-side-conditions.rkt" "term.rkt" "term-fn.rkt" "loc-wrapper-ct.rkt" racket/stxparam-exptime racket/base racket/syntax syntax/id-table racket/list syntax/parse)) (require (for-template "term.rkt")) (struct derivation (term name subs) #:transparent #:guard (λ (term name subs struct-name) (unless (or (not name) (string? name)) (raise-argument-error struct-name "(or/c string? #f)" 1 term name subs)) (unless (and (list? subs) (andmap derivation? subs)) (raise-argument-error struct-name "derivation?" 2 term name subs)) (values term name subs))) ;; structs that hold intermediate results when building a derivation (struct derivation-subs-acc (subs-so-far this-output) #:transparent) (struct derivation-with-output-only (output name subs) #:transparent) ;; Intermediate structures recording clause "extras" for typesetting. (define-struct metafunc-extra-side-cond (expr)) (define-struct metafunc-extra-where (lhs rhs)) (define-struct metafunc-extra-fresh (vars)) (define-for-syntax (judgment-form-id? stx) (and (identifier? stx) (judgment-form? (syntax-local-value stx (λ () #f))))) (begin-for-syntax ;; pre: (judgment-form-id? stx) holds (define (lookup-judgment-form-id stx) (define jf-pe (judgment-form-pending-expansion)) (if (and jf-pe (free-identifier=? (car jf-pe) stx)) (cdr jf-pe) (syntax-local-value stx))) (define judgment-form-pending-expansion (make-parameter #f))) (define-for-syntax (prune-syntax stx) (datum->syntax (identifier-prune-lexical-context #'whatever '(#%app #%datum)) (let loop ([stx stx]) (syntax-case stx () [(a . b) (datum->syntax (identifier-prune-lexical-context #'whatever '(#%app)) (cons (loop #'a) (loop #'b)) stx)] [x (identifier? #'x) (identifier-prune-lexical-context #'x (list (syntax-e #'x) '#%top))] [() (datum->syntax #f '() stx)] [_ (datum->syntax (identifier-prune-lexical-context #'whatever '(#%datum)) (syntax->datum stx) stx)])))) (define-syntax (--> stx) (raise-syntax-error '--> "used outside of reduction-relation")) (define-syntax (fresh stx) (raise-syntax-error 'fresh "used outside of reduction-relation")) (define-syntax (with stx) (raise-syntax-error 'with "used outside of reduction-relation")) (define-for-syntax (generate-binding-constraints names names/ellipses bindings syn-err-name) (define (id/depth stx) (syntax-case stx () [(s (... ...)) (let ([r (id/depth #'s)]) (make-id/depth (id/depth-id r) (add1 (id/depth-depth r)) (id/depth-mismatch? r)))] [s (make-id/depth #'s 0 #f)])) (define temporaries (generate-temporaries names)) (values (for/fold ([cs '()]) ([n names] [w/e names/ellipses] [x temporaries]) (cond [(hash-ref bindings (syntax-e n) #f) => (λ (b) (let ([b-id/depth (id/depth b)] [n-id/depth (id/depth w/e)]) (if (= (id/depth-depth b-id/depth) (id/depth-depth n-id/depth)) (cons #`(equal? #,x (term #,b)) cs) (raise-ellipsis-depth-error syn-err-name (id/depth-id n-id/depth) (id/depth-depth n-id/depth) (id/depth-id b-id/depth) (id/depth-depth b-id/depth)))))] [else cs])) temporaries (for/fold ([extended bindings]) ([name names] [w/ellipses names/ellipses]) (hash-set extended (syntax-e name) w/ellipses)))) ;; the withs, freshs, and side-conditions come in backwards order (define-for-syntax (bind-withs orig-name main lang lang-nts stx where-mode body names w/ellipses side-condition-unquoted? jf-results-id) (with-disappeared-uses (let loop ([stx stx] [to-not-be-in main] [env (make-immutable-hash (map (λ (x e) (cons (syntax-e x) e)) names w/ellipses))]) (syntax-case stx (fresh judgment-holds) [() body] [((-where x e) y ...) (where-keyword? #'-where) (let () (with-syntax ([(side-conditions-rewritten (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs lang-nts 'reduction-relation #t #'x)] [lang-stx lang]) (define-values (binding-constraints temporaries env+) (generate-binding-constraints (syntax->list #'(names ...)) (syntax->list #'(names/ellipses ...)) env orig-name)) (with-syntax ([(binding-constraints ...) binding-constraints] [(x ...) temporaries]) (define rest-body (loop #'(y ...) #`(list x ... #,to-not-be-in) env+)) #`(#,(case where-mode [(flatten) #'combine-where-results/flatten] [(predicate) #'combine-where-results/predicate] [else (error 'unknown-where-mode "~s" where-mode)]) (match-pattern (compile-pattern #,lang `side-conditions-rewritten #t) (term/nts e #,lang-nts)) (λ (bindings) (let ([x (lookup-binding bindings 'names)] ...) (and binding-constraints ... (term-let ([names/ellipses x] ...) #,rest-body))))))))] [((-side-condition s ...) y ...) (side-condition-keyword? #'-side-condition) (if side-condition-unquoted? #`(and s ... #,(loop #'(y ...) to-not-be-in env)) #`(and (term s) ... #,(loop #'(y ...) to-not-be-in env)))] [((fresh x) y ...) (identifier? #'x) #`(term-let ([x (variable-not-in #,to-not-be-in 'x)]) #,(loop #'(y ...) #`(list (term x) #,to-not-be-in) env))] [((fresh x name) y ...) (identifier? #'x) #`(term-let ([x (let ([the-name (term name)]) (verify-name-ok '#,orig-name the-name) (variable-not-in #,to-not-be-in the-name))]) #,(loop #'(y ...) #`(list (term x) #,to-not-be-in) env))] [((fresh (y) (x ...)) z ...) #`(term-let ([(y #,'...) (variables-not-in #,to-not-be-in (map (λ (_ignore_) 'y) (term (x ...))))]) #,(loop #'(z ...) #`(list (term (y #,'...)) #,to-not-be-in) env))] [((fresh (y) (x ...) names) z ...) #`(term-let ([(y #,'...) (let ([the-names (term names)] [len-counter (term (x ...))]) (verify-names-ok '#,orig-name the-names len-counter) (variables-not-in #,to-not-be-in the-names))]) #,(loop #'(z ...) #`(list (term (y #,'...)) #,to-not-be-in) env))] [((judgment-holds j) . after) (loop (cons #'j #'after) to-not-be-in env)] [((form-name . pats) . after) (judgment-form-id? #'form-name) (let*-values ([(premise) (syntax-case stx () [(p . _) #'p])] [(rest-clauses under-ellipsis?) (syntax-case #'after () [(maybe-ellipsis . more) (ellipsis? #'maybe-ellipsis) (values #'more #t)] [_ (values #'after #f)])] [(judgment-form) (lookup-judgment-form-id #'form-name)] [(mode) (judgment-form-mode judgment-form)] [(judgment-proc) (judgment-form-proc judgment-form)] [(input-template output-pre-pattern) (let-values ([(in out) (split-by-mode (syntax->list #'pats) mode)]) (if under-ellipsis? (let ([ellipsis (syntax/loc premise (... ...))]) (values #`(#,in #,ellipsis) #`(#,out #,ellipsis))) (values in out)))] [(output-pattern output-names output-names/ellipses) (with-syntax ([(output names names/ellipses) (rewrite-side-conditions/check-errs lang-nts orig-name #t output-pre-pattern)]) (values #'output (syntax->list #'names) (syntax->list #'names/ellipses)))] [(binding-constraints temporaries env+) (generate-binding-constraints output-names output-names/ellipses env orig-name)] [(rest-body) (loop rest-clauses #`(list judgment-output #,to-not-be-in) env+)] [(call) (let ([input (quasisyntax/loc premise (term/nts #,input-template #,lang-nts))]) (define (make-traced input) (quasisyntax/loc premise (call-judgment-form 'form-name #,judgment-proc '#,mode #,input #,(if jf-results-id #''() #f)))) (if under-ellipsis? #`(repeated-premise-outputs #,input (λ (x) #,(make-traced #'x))) (make-traced input)))]) (record-disappeared-uses (list #'form-name)) (with-syntax ([(output-name ...) output-names] [(output-name/ellipsis ...) output-names/ellipses] [(temp ...) temporaries] [(binding-constraint ...) binding-constraints]) #`(begin (void #,(defined-check judgment-proc "judgment form" #:external #'form-name)) (judgment-form-bind-withs/proc #,lang `#,output-pattern #,call #,under-ellipsis? #,jf-results-id (λ (bindings #,(if jf-results-id jf-results-id '_ignored)) (let ([temp (lookup-binding bindings 'output-name)] ...) (and binding-constraint ... (term-let ([output-name/ellipsis temp] ...) #,rest-body))))))))])))) (define (judgment-form-bind-withs/proc lang output-pattern output under-ellipsis? old-maps do-something) (let ([compiled-pattern (compile-pattern lang output-pattern #t)]) (for/fold ([outputs '()]) ([sub-output (in-list output)]) (define sub-tree (if under-ellipsis? (map derivation-subs-acc-subs-so-far sub-output) (derivation-subs-acc-subs-so-far sub-output))) (define term (if under-ellipsis? (map derivation-subs-acc-this-output sub-output) (derivation-subs-acc-this-output sub-output))) (define mtchs (match-pattern compiled-pattern term)) (if mtchs (for/fold ([outputs outputs]) ([mtch (in-list mtchs)]) (define mtch-outputs (do-something (mtch-bindings mtch) (and old-maps (if under-ellipsis? (append (reverse sub-tree) old-maps) (cons sub-tree old-maps))))) (if mtch-outputs (append mtch-outputs outputs) outputs)) outputs)))) (define (combine-where-results/flatten mtchs result) (and mtchs (for/fold ([r '()]) ([m mtchs]) (let ([s (result (mtch-bindings m))]) (if s (append s r) r))))) (define (combine-where-results/predicate mtchs result) (and mtchs (for/or ([mtch mtchs]) (result (mtch-bindings mtch))))) (define (repeated-premise-outputs inputs premise) (if (null? inputs) '(()) (let ([output (premise (car inputs))]) (if (null? output) '() (for*/list ([o output] [os (repeated-premise-outputs (cdr inputs) premise)]) (cons o os)))))) (define (call-judgment-form form-name form-proc mode input derivation-init) (define traced (current-traced-metafunctions)) (define vecs (if (or (eq? 'all traced) (memq form-name traced)) (let ([outputs #f]) (define spacers (for/fold ([s '()]) ([m mode]) (case m [(I) s] [(O) (cons '_ s)]))) (define (wrapped . _) (set! outputs (form-proc form-proc input derivation-init)) (for/list ([output (in-list outputs)]) (cons form-name (assemble mode input (derivation-with-output-only-output output))))) (apply trace-call form-name wrapped (assemble mode input spacers)) outputs) (form-proc form-proc input derivation-init))) (for/list ([v (in-list vecs)]) (define subs (derivation-with-output-only-subs v)) (define rulename (derivation-with-output-only-name v)) (define this-output (derivation-with-output-only-output v)) (derivation-subs-acc (and subs (derivation (cons form-name (assemble mode input this-output)) rulename (reverse subs))) this-output))) (define (assemble mode inputs outputs) (let loop ([ms mode] [is inputs] [os outputs]) (if (null? ms) '() (case (car ms) [(I) (cons (car is) (loop (cdr ms) (cdr is) os))] [(O) (cons (car os) (loop (cdr ms) is (cdr os)))])))) (define (verify-name-ok orig-name the-name) (unless (symbol? the-name) (error orig-name "expected a single name, got ~s" the-name))) (define (verify-names-ok orig-name the-names len-counter) (unless (and (list? the-names) (andmap symbol? the-names)) (error orig-name "expected a sequence of names, got ~s" the-names)) (unless (= (length len-counter) (length the-names)) (error orig-name "expected the length of the sequence of names to be ~a, got ~s" (length len-counter) the-names))) (define current-traced-metafunctions (make-parameter '())) (define-for-syntax (mode-keyword stx) (raise-syntax-error #f "keyword invalid outside of mode specification" stx)) (define-syntax I mode-keyword) (define-syntax O mode-keyword) (define-for-syntax (check-judgment-arity stx judgment) (syntax-case judgment () [(form-name pat ...) (judgment-form-id? #'form-name) (let ([expected (length (judgment-form-mode (lookup-judgment-form-id #'form-name)))] [actual (length (syntax->list #'(pat ...)))]) (unless (= actual expected) (raise-syntax-error #f (format "mode specifies a ~a-ary relation but use supplied ~a term~a" expected actual (if (= actual 1) "" "s")) judgment)))] [(form-name pat ...) (raise-syntax-error #f "expected a judgment form name" stx #'form-name)])) (define (substitute from to pat) (let recur ([p pat]) (syntax-case p (side-condition) [(side-condition p c) #`(side-condition #,(recur #'p) c)] [(p ...) #`(#,@(map recur (syntax->list #'(p ...))))] [else (if (and (identifier? p) (bound-identifier=? p from)) to p)]))) (define-for-syntax (definition-nts lang orig-stx syn-error-name) (unless (identifier? lang) (raise-syntax-error #f "expected an identifier in the language position" orig-stx lang)) (language-id-nts lang syn-error-name)) (define-for-syntax (lhs-lws clauses) (with-syntax ([((lhs-for-lw _ ...) ...) clauses]) (map (λ (x) (to-lw/proc (datum->syntax #f (cdr (syntax-e x)) x))) (syntax->list #'(lhs-for-lw ...))))) (define-syntax (define-judgment-form stx) (not-expression-context stx) (syntax-case stx () [(def-form-id lang . body) (do-extended-judgment-form #'lang (syntax-e #'def-form-id) #'body #f stx)])) (define-syntax (define-extended-judgment-form stx) (not-expression-context stx) (syntax-case stx () [(def-form-id lang original-id . body) (begin (unless (judgment-form-id? #'original-id) (raise-syntax-error 'define-extended-judgment-form "expected a judgment form" stx #'original-id)) (do-extended-judgment-form #'lang 'define-extended-judgment-form #'body #'original-id stx))])) (define-for-syntax (do-extended-judgment-form lang syn-err-name body orig stx) (define nts (definition-nts lang stx syn-err-name)) (define-values (judgment-form-name dup-form-names mode position-contracts clauses rule-names) (parse-judgment-form-body body syn-err-name stx (identifier? orig))) (define definitions #`(begin (define-syntax #,judgment-form-name (judgment-form '#,judgment-form-name '#,(cdr (syntax->datum mode)) #'judgment-form-runtime-proc #'mk-judgment-form-proc #'#,lang #'judgment-form-lws '#,rule-names #'judgment-runtime-gen-clauses #'mk-judgment-gen-clauses)) (define mk-judgment-form-proc (compile-judgment-form-proc #,judgment-form-name #,mode #,lang #,clauses #,rule-names #,position-contracts #,orig #,stx #,syn-err-name)) (define judgment-form-runtime-proc (mk-judgment-form-proc #,lang)) (define judgment-form-lws (compiled-judgment-form-lws #,clauses)) (define mk-judgment-gen-clauses (compile-judgment-gen-clauses #,judgment-form-name #,mode #,lang #,clauses #,position-contracts #,orig #,stx #,syn-err-name judgment-runtime-gen-clauses)) (define judgment-runtime-gen-clauses (mk-judgment-gen-clauses #,lang (λ () (judgment-runtime-gen-clauses)))))) (syntax-property (values ;prune-syntax (if (eq? 'top-level (syntax-local-context)) ; Introduce the names before using them, to allow ; judgment form definition at the top-level. #`(begin (define-syntaxes (judgment-form-runtime-proc judgment-form-lws judgment-runtime-gen-clauses) (values)) #,definitions) definitions)) 'disappeared-use (map syntax-local-introduce dup-form-names))) (define-for-syntax (parse-judgment-form-body body syn-err-name full-stx extension?) (define-syntax-class pos-mode #:literals (I O) (pattern I) (pattern O)) (define-syntax-class mode-spec #:description "mode specification" (pattern (_:id _:pos-mode ...))) (define-syntax-class contract-spec #:description "contract specification" (pattern (_:id _:expr ...))) (define (horizontal-line? id) (regexp-match? #rx"^-+$" (symbol->string (syntax-e id)))) (define-syntax-class horizontal-line (pattern x:id #:when (horizontal-line? #'x))) (define-syntax-class name (pattern x #:when (or (and (symbol? (syntax-e #'x)) (not (horizontal-line? #'x)) (not (eq? '... (syntax-e #'x)))) (string? (syntax-e #'x))))) (define (parse-rules rules) (define-values (backward-rules backward-names) (for/fold ([parsed-rules '()] [names '()]) ([rule rules]) (syntax-parse rule [(prem ... _:horizontal-line n:name conc) (values (cons #'(conc prem ...) parsed-rules) (cons #'n names))] [(prem ... _:horizontal-line conc) (values (cons #'(conc prem ...) parsed-rules) (cons #f names))] [(conc prem ... n:name) (values (cons #'(conc prem ...) parsed-rules) (cons #'n names))] [else (values (cons rule parsed-rules) (cons #f names))]))) (values (reverse backward-rules) (reverse backward-names))) (define-values (name/mode mode-stx name/contract contract rules rule-names) (syntax-parse body #:context full-stx [((~or (~seq #:mode ~! mode:mode-spec) (~seq #:contract ~! contract:contract-spec)) ... rule:expr ...) (let-values ([(name/mode mode) (syntax-parse #'(mode ...) [((name the-mode ...)) (values #'name (car (syntax->list #'(mode ...))))] [_ (raise-syntax-error #f (if (null? (syntax->list #'(mode ...))) "expected definition to include a mode specification" "expected definition to include only one mode specification") full-stx)])] [(name/ctc ctc) (syntax-parse #'(contract ...) [() (values #f #f)] [((name . contract)) (values #'name (syntax->list #'contract))] [(_ . dups) (raise-syntax-error syn-err-name "expected at most one contract specification" #f #f (syntax->list #'dups))])]) (define-values (parsed-rules rule-names) (parse-rules (syntax->list #'(rule ...)))) (values name/mode mode name/ctc ctc parsed-rules rule-names))])) (check-clauses full-stx syn-err-name rules #t) (check-dup-rule-names full-stx syn-err-name rule-names) (check-arity-consistency mode-stx contract full-stx) (define-values (form-name dup-names) (syntax-case rules () [() (not extension?) (raise-syntax-error #f "expected at least one rule" full-stx)] [_ (defined-name (list name/mode name/contract) rules full-stx)])) (define string-rule-names (for/list ([name (in-list rule-names)]) (cond [(not name) name] [(symbol? (syntax-e name)) (symbol->string (syntax-e name))] [else (syntax-e name)]))) (values form-name dup-names mode-stx contract rules string-rule-names)) ;; names : (listof (or/c #f syntax[string])) (define-for-syntax (check-dup-rule-names full-stx syn-err-name names) (define tab (make-hash)) (for ([name (in-list names)]) (when (syntax? name) (define k (if (symbol? (syntax-e name)) (symbol->string (syntax-e name)) (syntax-e name))) (hash-set! tab k (cons name (hash-ref tab k '()))))) (for ([(k names) (in-hash tab)]) (unless (= 1 (length names)) (raise-syntax-error syn-err-name "duplicate rule names" (car names) #f (cdr names))))) (define-for-syntax (check-arity-consistency mode-stx contracts full-def) (when (and contracts (not (= (length (cdr (syntax->datum mode-stx))) (length contracts)))) (raise-syntax-error #f "mode and contract specify different numbers of positions" full-def))) (define-for-syntax (defined-name declared-names clauses orig-stx) (with-syntax ([(((used-names _ ...) _ ...) ...) clauses]) (define-values (the-name other-names) (let ([present (filter values declared-names)]) (if (null? present) (values (car (syntax->list #'(used-names ...))) (cdr (syntax->list #'(used-names ...)))) (values (car present) (append (cdr present) (syntax->list #'(used-names ...))))))) (let loop ([others other-names]) (cond [(null? others) (values the-name other-names)] [else (unless (eq? (syntax-e the-name) (syntax-e (car others))) (raise-syntax-error #f "expected the same name in both positions" orig-stx the-name (list (car others)))) (loop (cdr others))])))) (define-syntax (judgment-holds/derivation stx) (syntax-case stx () [(_ stx-name derivation? judgment) #`(not (null? #,(syntax/loc stx (judgment-holds/derivation stx-name derivation? judgment #t))))] [(_ stx-name derivation? (form-name . pats) tmpl) (judgment-form-id? #'form-name) (let* ([syn-err-name (syntax-e #'stx-name)] [lang (judgment-form-lang (lookup-judgment-form-id #'form-name))] [nts (definition-nts lang stx syn-err-name)] [judgment (syntax-case stx () [(_ _ _ judgment _) #'judgment])] [derivation? (syntax-e #'derivation?)] [id-or-not (if derivation? (car (generate-temporaries '(jf-derivation-lst))) #f)] [main-stx (bind-withs syn-err-name '() lang nts (list judgment) 'flatten (if derivation? id-or-not #`(list (term #,#'tmpl #:lang #,lang))) '() '() #f id-or-not)]) (check-judgment-arity stx judgment) (syntax-property (if id-or-not #`(let ([#,id-or-not '()]) #,main-stx) #`(sort #,main-stx string<=? #:key (λ (x) (format "~s" x)))) 'disappeared-use (syntax-local-introduce #'form-name)))] [(_ stx-name derivation? (not-form-name . _) . _) (not (judgment-form-id? #'form-name)) (raise-syntax-error (syntax-e #'stx-name) "expected a judgment form name" #'not-form-name)] [(_ stx-name . whatever) (raise-syntax-error (syntax-e #'stx-name) "bad syntax" stx)])) (define-syntax (judgment-holds stx) (syntax-case stx () [(_ args ...) #'(#%expression (judgment-holds/derivation judgment-holds #f args ...))])) (define-syntax (build-derivations stx) (syntax-case stx () [(_ jf-expr) #'(#%expression (judgment-holds/derivation build-derivations #t jf-expr any))])) (define-for-syntax (do-compile-judgment-form-proc name mode-stx clauses rule-names contracts nts orig stx syn-error-name) (with-syntax ([(init-jf-derivation-id) (generate-temporaries '(init-jf-derivation-id))]) (define mode (cdr (syntax->datum mode-stx))) (define-values (input-contracts output-contracts) (if contracts (let-values ([(ins outs) (split-by-mode contracts mode)]) (values ins outs)) (values #f #f))) (define (compile-clause clause clause-name) (syntax-case clause () [((_ . conc-pats) . prems) (let-values ([(input-pats output-pats) (split-by-mode (syntax->list #'conc-pats) mode)]) (with-syntax ([(lhs (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs nts syn-error-name #t input-pats)] [(jf-derivation-id) (generate-temporaries '(jf-derivation-id))]) (define (contracts-compilation ctcs) (and ctcs (with-syntax ([(ctc ...) ctcs]) #`(list (compile-pattern lang `ctc #f) ...)))) (define body (parameterize ([judgment-form-pending-expansion (cons name (struct-copy judgment-form (lookup-judgment-form-id name) [proc #'recur]))]) (bind-withs syn-error-name '() #'lang nts (syntax->list #'prems) 'flatten #`(list (derivation-with-output-only (term/nts (#,@output-pats) #,nts) #,clause-name jf-derivation-id)) (syntax->list #'(names ...)) (syntax->list #'(names/ellipses ...)) #f #'jf-derivation-id))) (with-syntax ([(compiled-lhs compiled-input-ctcs compiled-output-ctcs) (generate-temporaries '(compiled-lhs compiled-input-ctcs compiled-output-ctcs))]) #`( ;; pieces of a 'let' expression to be combined: first some bindings ([compiled-lhs (compile-pattern lang `lhs #t)] #,@(if (contracts-compilation input-contracts) (list #`[compiled-input-ctcs #,(contracts-compilation input-contracts)]) (list)) #,@(if (contracts-compilation output-contracts) (list #`[compiled-output-ctcs #,(contracts-compilation output-contracts)]) (list))) ;; and then the body of the let, but expected to be behind a (λ (input) ...). (let ([jf-derivation-id init-jf-derivation-id]) (begin #,@(if (contracts-compilation input-contracts) (list #`(check-judgment-form-contract '#,name input compiled-input-ctcs 'I '#,mode)) (list)) (combine-judgment-rhses compiled-lhs input (λ (bnds) (term-let ([names/ellipses (lookup-binding bnds 'names)] ...) #,body)) #,(if (contracts-compilation output-contracts) #`(λ (output) (check-judgment-form-contract '#,name output compiled-output-ctcs 'O '#,mode)) #`void))))))))])) (when (identifier? orig) (define orig-mode (judgment-form-mode (lookup-judgment-form-id orig))) (unless (equal? mode orig-mode) (raise-syntax-error syn-error-name (format "mode for extended judgment form does not match original mode; got ~s for the original and ~s for the extension" `(,(syntax-e orig) ,@orig-mode) `(,(syntax-e name) ,@mode)) stx mode-stx))) (with-syntax ([(((clause-proc-binding ...) clause-proc-body) ...) (map compile-clause clauses rule-names)]) (with-syntax ([(clause-proc-body-backwards ...) (reverse (syntax->list #'(clause-proc-body ...)))]) (if (identifier? orig) (with-syntax ([orig-mk (judgment-form-mk-proc (lookup-judgment-form-id orig))]) #`(λ (lang) (let (clause-proc-binding ... ...) (let ([prev (orig-mk lang)]) (λ (recur input init-jf-derivation-id) (append (prev recur input init-jf-derivation-id) clause-proc-body-backwards ...)))))) #`(λ (lang) (let (clause-proc-binding ... ...) (λ (recur input init-jf-derivation-id) (append clause-proc-body-backwards ...))))))))) (define (combine-judgment-rhses compiled-lhs input rhs check-output) (define mtchs (match-pattern compiled-lhs input)) (cond [mtchs (define output-table (make-hash)) (for ([m (in-list mtchs)]) (define os (rhs (mtch-bindings m))) (when os (for ([x (in-list os)]) (hash-set! output-table x #t)))) (define outputs (hash-map output-table (λ (k v) k))) (for ([output (in-list outputs)]) (check-output output)) outputs] [else '()])) (define-for-syntax (do-compile-judgment-form-lws clauses) (syntax-case clauses () [(((_ . conc-body) . prems) ...) (let ([rev-premss ; for consistency with metafunction extras (for/list ([prems (syntax->list #'(prems ...))]) (reverse (syntax->list prems)))] [no-rhss (map (λ (_) '()) clauses)]) #`(generate-lws #t (conc-body ...) #,(lhs-lws clauses) #,rev-premss #,no-rhss #f))])) (define (check-judgment-form-contract form-name term+trees contracts mode modes) (define terms (if (eq? mode 'O) (derivation-with-output-only-output term+trees) term+trees)) (define description (case mode [(I) "input"] [(O) "output"])) (when contracts (let loop ([rest-modes modes] [rest-terms terms] [rest-ctcs contracts] [pos 1]) (unless (null? rest-modes) (if (eq? mode (car rest-modes)) (if (match-pattern (car rest-ctcs) (car rest-terms)) (loop (cdr rest-modes) (cdr rest-terms) (cdr rest-ctcs) (+ 1 pos)) (redex-error form-name "~a ~s at position ~s does not match its contract" description (car rest-terms) pos)) (loop (cdr rest-modes) rest-terms rest-ctcs (+ 1 pos))))))) (define-for-syntax (mode-check mode clauses nts syn-err-name orig-stx) (define ((check-template bound-anywhere) temp bound) (let check ([t temp]) (syntax-case t (unquote) [(unquote . _) (raise-syntax-error syn-err-name "unquote unsupported" t)] [x (identifier? #'x) (unless (cond [(free-id-table-ref bound-anywhere #'x #f) (free-id-table-ref bound #'x #f)] [(id-binds? nts #t #'x) (term-fn? (syntax-local-value #'x (λ () #f)))] [else #t]) (raise-syntax-error syn-err-name "unbound pattern variable" #'x))] [(u ...) (for-each check (syntax->list #'(u ...)))] [_ (void)]))) (define ((bind kind) pat bound) (define-values (ids _) (extract-names nts syn-err-name #t pat kind)) (for/fold ([b bound]) ([x ids]) (free-id-table-set b x #t))) (define (split-body judgment) (syntax-case judgment () [(form-name . body) (split-by-mode (syntax->list #'body) (judgment-form-mode (lookup-judgment-form-id #'form-name)))])) (define (drop-ellipses prems) (syntax-case prems () [() '()] [(prem maybe-ellipsis . remaining) (ellipsis? #'maybe-ellipsis) (syntax-case #'prem () [(form-name . _) (judgment-form-id? #'form-name) (cons #'prem (drop-ellipses #'remaining))] [_ (raise-syntax-error syn-err-name "ellipses must follow judgment form uses" #'maybe-ellipsis)])] [(prem . remaining) (cons #'prem (drop-ellipses #'remaining))])) (define (fold-clause pat-pos tmpl-pos acc-init clause) (syntax-case clause () [(conc . prems) (let-values ([(conc-in conc-out) (split-body #'conc)]) (check-judgment-arity orig-stx #'conc) (define acc-out (for/fold ([acc (foldl pat-pos acc-init conc-in)]) ([prem (drop-ellipses #'prems)]) (syntax-case prem () [(-where pat tmpl) (where-keyword? #'-where) (begin (tmpl-pos #'tmpl acc) (pat-pos #'pat acc))] [(-side-condition tmpl) (side-condition-keyword? #'-side-condition) (begin (tmpl-pos #'tmpl acc) acc)] [(form-name . _) (if (judgment-form-id? #'form-name) (let-values ([(prem-in prem-out) (split-body prem)]) (check-judgment-arity orig-stx prem) (for ([pos prem-in]) (tmpl-pos pos acc)) (foldl pat-pos acc prem-out)) (raise-syntax-error syn-err-name "expected judgment form name" #'form-name))] [_ (raise-syntax-error syn-err-name "malformed premise" prem)]))) (for ([pos conc-out]) (tmpl-pos pos acc-out)) acc-out)])) (for ([clause clauses]) (define do-tmpl (check-template (fold-clause (bind 'rhs-only) void (make-immutable-free-id-table) clause))) (fold-clause (bind 'rhs-only) do-tmpl (make-immutable-free-id-table) clause))) (define-syntax (generate-lws stx) (syntax-case stx () [(_ relation? seq-of-lhs seq-of-lhs-for-lw seq-of-tl-side-cond/binds seq-of-rhs side-condition-unquoted?) (with-syntax ([(rhs/lw ...) (syntax-case #'relation? () [#t (map (λ (x) #`(list #,@(map to-lw/proc (syntax->list x)))) (syntax->list #'seq-of-rhs))] [#f (map to-lw/proc (syntax->list #'seq-of-rhs))])] [(((bind-id/lw . bind-pat/lw) ...) ...) ;; Also for pict, extract pattern bindings (map name-pattern-lws (syntax->list #'seq-of-lhs))] [((where/sc/lw ...) ...) ;; Also for pict, extract where bindings (map (λ (hm) (map (λ (lst) (syntax-case lst (unquote side-condition where) [(form-name . _) (judgment-form-id? #'form-name) #`(make-metafunc-extra-side-cond #,(to-lw/proc lst))] [(form-name . _) (judgment-form-id? #'form-name) #`(make-metafunc-extra-side-cond #,(to-lw/proc lst))] [(where pat (unquote (f _ _))) (and (or (identifier? #'pat) (andmap identifier? (syntax->list #'pat))) (or (free-identifier=? #'f #'variable-not-in) (free-identifier=? #'f #'variables-not-in))) (with-syntax ([(ids ...) (map to-lw/proc (if (identifier? #'pat) (list #'pat) (syntax->list #'pat)))]) #`(make-metafunc-extra-fresh (list ids ...)))] [(where pat exp) #`(make-metafunc-extra-where #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))] [(side-condition x) #`(make-metafunc-extra-side-cond #,(if (syntax-e #'side-condition-unquoted?) (to-lw/uq/proc #'x) (to-lw/proc #'x)))] [maybe-ellipsis (ellipsis? #'maybe-ellipsis) (to-lw/proc #'maybe-ellipsis)])) (visible-extras hm))) (syntax->list #'seq-of-tl-side-cond/binds))] [(((where-bind-id/lw . where-bind-pat/lw) ...) ...) (map (λ (clauses) (for/fold ([binds '()]) ([clause (visible-extras clauses)]) (syntax-case clause (where) [(form-name . pieces) (judgment-form-id? #'form-name) (let*-values ([(mode) (judgment-form-mode (lookup-judgment-form-id #'form-name))] [(_ outs) (split-by-mode (syntax->list #'pieces) mode)]) (for/fold ([binds binds]) ([out outs]) (append (name-pattern-lws out) binds)))] [(where lhs rhs) (append (name-pattern-lws #'lhs) binds)] [_ binds]))) (syntax->list #'seq-of-tl-side-cond/binds))] [(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...) ;; Also for pict, extract pattern bindings (map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x)))) (extract-term-let-binds x))) (syntax->list #'seq-of-rhs))] [(x-lhs-for-lw ...) #'seq-of-lhs-for-lw]) #'(list (list x-lhs-for-lw (list (make-metafunc-extra-where bind-id/lw bind-pat/lw) ... (make-metafunc-extra-where where-bind-id/lw where-bind-pat/lw) ... (make-metafunc-extra-where rhs-bind-id/lw rhs-bind-pat/lw/uq) ... where/sc/lw ...) rhs/lw) ...))])) (define-for-syntax (visible-extras extras) (for/fold ([visible empty]) ([extra (syntax->list extras)]) (syntax-case extra (where/hidden side-condition/hidden judgment-holds) [(where/hidden pat exp) visible] [(side-condition/hidden x) visible] [(judgment-holds judgment) (cons #'judgment visible)] [_ (cons extra visible)]))) (define-syntax (compile-judgment-form-proc stx) (syntax-case stx () [(_ judgment-form-name mode-arg lang clauses rule-names ctcs orig full-def syn-err-name) (let ([nts (definition-nts #'lang #'full-def (syntax-e #'syn-err-name))] [clauses (syntax->list #'clauses)] [rule-names (syntax->datum #'rule-names)] [syn-err-name (syntax-e #'syn-err-name)]) (mode-check (cdr (syntax->datum #'mode-arg)) clauses nts syn-err-name stx) (define contracts (syntax-case #'ctcs () [#f #f] [(p ...) (map (λ (pat) (with-syntax ([(pat (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs nts #'syn-error-name #f pat)]) #'pat)) (syntax->list #'(p ...)))])) (do-compile-judgment-form-proc #'judgment-form-name #'mode-arg clauses rule-names contracts nts #'orig #'full-def syn-err-name))])) (define-syntax (compiled-judgment-form-lws stx) (syntax-case stx () [(_ clauses) (do-compile-judgment-form-lws (syntax->list #'clauses))])) (define-for-syntax (extract-term-let-binds lhs) (let loop ([lhs lhs]) (syntax-case* lhs (term-let) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) [(term-let ((x e1) ...) e2 ...) (append (map cons (syntax->list #'(x ...)) (syntax->list #'(e1 ...))) (loop #'(e2 ...)))] ;; FIXME: should follow the grammar of patterns! [(a . b) (append (loop #'a) (loop #'b))] [_else null]))) (define-for-syntax (name-pattern-lws pat) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x)))) (extract-pattern-binds pat))) (define-for-syntax (extract-pattern-binds lhs) (let loop ([lhs lhs]) (syntax-case* lhs (name) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) [(name id expr) (identifier? #'id) (cons (cons #'id #'expr) (loop #'expr))] ;; FIXME: should follow the grammar of patterns! [(a . b) (append (loop #'a) (loop #'b))] [_else null]))) (define-for-syntax (check-clauses stx syn-error-name rest relation?) (syntax-case rest () [([(lhs ...) roc1 roc2 ...] ...) rest] [([(lhs ...) rhs ...] ...) (if relation? rest (begin (for-each (λ (clause) (syntax-case clause () [(a b) (void)] [x (raise-syntax-error syn-error-name "expected a pattern and a right-hand side" stx clause)])) rest) (raise-syntax-error syn-error-name "error checking failed.3" stx)))] [([x roc ...] ...) (begin (for-each (λ (x) (syntax-case x () [(lhs ...) (void)] [x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)])) (syntax->list #'(x ...))) (raise-syntax-error syn-error-name "error checking failed.1" stx))] [(x ...) (begin (for-each (λ (x) (syntax-case x () [(stuff stuff2 ...) (void)] [x (raise-syntax-error syn-error-name "expected a clause" stx #'x)])) (syntax->list #'(x ...))) (raise-syntax-error syn-error-name "error checking failed.2" stx))])) (define-for-syntax (split-by-mode xs mode) (for/fold ([ins '()] [outs '()]) ([x (reverse xs)] [m (reverse mode)]) (case m [(I) (values (cons x ins) outs)] [(O) (values ins (cons x outs))] [else (error 'split-by-mode "ack ~s" m)]))) (define-for-syntax (fuse-by-mode ins outs mode) (let loop ([is (reverse ins)] [os (reverse outs)] [ms (reverse mode)] [res '()]) (define err (λ () (error 'fuse-by-mode "mismatched mode and split: ~s ~s ~s" ins outs mode))) (cond [(and (empty? ms) (empty? is) (empty? os)) res] [(empty? ms) (err)] [else (case (car ms) [(I) (if (empty? is) (err) (loop (cdr is) os (cdr ms) (cons (car is) res)))] [(O) (if (empty? os) (err) (loop is (cdr os) (cdr ms) (cons (car os) res)))] [else (error 'fuse-by-mode "ack ~s" (car ms))])]))) (define-for-syntax (ellipsis? stx) (and (identifier? stx) (free-identifier=? stx (quote-syntax ...)))) (define-for-syntax (where-keyword? id) (or (free-identifier=? id #'where) (free-identifier=? id #'where/hidden))) (define-for-syntax (side-condition-keyword? id) (or (free-identifier=? id #'side-condition) (free-identifier=? id #'side-condition/hidden))) ; ; ; ; ; ; ; ;; ;; ;;; ;; ;; ;;; ;; ;; ;;; ;;;;; ;;; ;;; ;; ;; ; ; ;; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ;;;;; ; ; ;;;;; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ;;;; ;;; ;;; ;;;; ;;;;; ;;;;; ;;; ;;;;; ;;; ;;; ;;; ; ; ; ;;; ; ; (define-syntax (compile-judgment-gen-clauses stx) (syntax-case stx () [(_ judgment-form-name mode-arg lang clauses ctcs orig full-def syn-err-name judgment-form-runtime-gen-clauses) (let ([clauses (syntax->list #'clauses)] [nts (definition-nts #'lang #'full-def (syntax-e #'syn-err-name))] [syn-err-name (syntax-e #'syn-err-name)] [mode (cdr (syntax->datum #'mode-arg))]) (with-syntax* ([(comp-clauses ...) (map (λ (c) (compile-gen-clause c mode nts syn-err-name #'judgment-form-name #'lang)) clauses)]) (if (identifier? #'orig) (with-syntax ([prev-mk (judgment-form-mk-gen-clauses (lookup-judgment-form-id #'orig))]) #`(λ (effective-lang judgment-form-runtime-gen-clauses) (define mk-prev-clauses (prev-mk effective-lang judgment-form-runtime-gen-clauses)) (λ () (append (mk-prev-clauses) #,(check-pats #'(list comp-clauses ...)))))) #`(λ (effective-lang judgment-form-runtime-gen-clauses) (λ () #,(check-pats #'(list comp-clauses ...)))))))])) (define-for-syntax (compile-gen-clause clause-stx mode nts syn-error-name jdg-name lang) (syntax-case clause-stx () [((conc-name . conc-body-raw) prems ...) (let*-values ([(conc/+ conc/-) (split-by-mode (syntax->list #'conc-body-raw) mode)] [(conc/+rw names) (rewrite-pats conc/+ nts)] [(ps-rw eqs p-names) (rewrite-prems #t (syntax->list #'(prems ...)) nts names 'define-judgment-form)] [(conc/-rw conc-mfs) (rewrite-terms conc/- p-names)] [(conc) (fuse-by-mode conc/+rw conc/-rw mode)]) (with-syntax ([(c ...) conc] [(c-mf ...) conc-mfs] [(eq ...) eqs] [(prem-bod ...) (reverse ps-rw)]) #`(clause '(list c ...) (list eq ...) (list c-mf ... prem-bod ...) effective-lang '#,jdg-name)))])) (define-for-syntax (rewrite-prems in-judgment-form? prems nts names what) (define (rewrite-jf prem-name prem-body ns ps-rw eqs) (define p-form (lookup-judgment-form-id prem-name)) (define p-mode (judgment-form-mode p-form)) (define p-clauses (judgment-form-gen-clauses p-form)) (define-values (p/-s p/+s) (split-by-mode (syntax->list prem-body) p-mode)) (define-values (p/-rws mf-apps) (rewrite-terms p/-s ns)) (define-values (p/+rws new-names) (rewrite-pats p/+s nts)) (define p-rw (fuse-by-mode p/-rws p/+rws p-mode)) (with-syntax ([(p ...) p-rw]) (values (cons #`(prem #,p-clauses '(list p ...)) (append mf-apps ps-rw)) eqs (append ns new-names)))) (define-values (prems-rev new-eqs new-names) (for/fold ([ps-rw '()] [eqs '()] [ns names]) ([prem prems]) (syntax-case prem () [(-where pat term) (where-keyword? #'-where) (let-values ([(term-rws mf-cs) (rewrite-terms (list #'term) ns)]) (with-syntax ([(pat-rw new-names) (rewrite/pat #'pat nts)]) (values (append mf-cs ps-rw) (cons #`(eqn 'pat-rw '#,(car term-rws)) eqs) (append (syntax->datum #'new-names) ns))))] [(side-cond . rest) (side-condition-keyword? #'side-cond) ;; TODO - side condition handling (values ps-rw eqs ns)] [(prem-name . prem-body) (and (judgment-form-id? #'prem-name) in-judgment-form?) (rewrite-jf #'prem-name #'prem-body ns ps-rw eqs)] [(judgment-holds (prem-name . prem-body)) (and (judgment-form-id? #'prem-name) (not in-judgment-form?)) (rewrite-jf #'prem-name #'prem-body ns ps-rw eqs)] [var (eq? '... (syntax-e #'var)) ;; TODO - fix when implementing ellipses (values ps-rw eqs ns)] [term (not in-judgment-form?) ;; in a relation (let-values ([(term-rws mf-cs) (rewrite-terms (list #'term) ns)]) (values (append mf-cs ps-rw) eqs ns))] [else (raise-syntax-error what "malformed premise" prem)]))) (values prems-rev new-eqs new-names)) (define-for-syntax (rewrite-pats pats nts) (with-syntax ([((pat-rw (names ...)) ...) (map (λ (p) (rewrite/pat p nts)) pats)]) (values (syntax->list #'(pat-rw ...)) (remove-duplicates (syntax->datum #'(names ... ...)))))) (define-for-syntax (rewrite/pat pat nts) (with-syntax ([(body (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs nts #'rewrite/pat #t pat)]) #'(body (names ...)))) (define-for-syntax (rewrite-terms terms names) (with-syntax* ([((term-pattern ((res-pat ((metafunc f) args-pat)) ...) body-pat) ...) (map (λ (t) (term-rewrite t names)) terms)] [((mf-clauses ...) ...) (map (λ (fs) (map (λ (f-id) (with-syntax ([f-id f-id]) #'(metafunc-proc-gen-clauses f-id))) (syntax->list fs))) (syntax->list #'((f ...) ...)))]) (values (syntax->list #'(body-pat ...)) (syntax->list #'((prem mf-clauses '(list args-pat res-pat)) ... ...))))) (define unsupported-pat-err-name (make-parameter #f)) (define-for-syntax (check-pats stx) (cond [(has-unsupported-pat? stx) => (λ (bad-stx) #`(error (unsupported-pat-err-name) "generation failed at unsupported pattern: ~s" #,bad-stx))] [else stx])) (define-for-syntax (has-unsupported-pat? stx) (syntax-case stx (repeat side-condition in-hole undatum-splicing) [(repeat . rest) (and (identifier? #'repeat) (eq? (syntax-e #'repeat) 'repeat)) #''(repeat . rest)] [(side-condition . rest) (and (identifier? #'side-condition) (eq? (syntax-e #'side-condition) 'side-condition)) #''(side-condition . rest)] [(in-hole . rest) (and (identifier? #'in-hole) (eq? (syntax-e #'in-hole) 'in-hole)) #''(in-hole . rest)] [(undatum . rest) (and (identifier? #'undatum) (eq? (syntax-e #'undatum) 'undatum)) #''(undatum . rest)] [(undatum-splicing .rest) (and (identifier? #'undatum-splicing) (eq? (syntax-e #'undatum-splicing) 'undatum-splicing)) #''(undatum-splicing .rest)] [(elems ...) (for/or ([e (in-list (syntax->list #'(elems ...)))]) (has-unsupported-pat? e))] [_ #f])) (provide define-judgment-form define-extended-judgment-form judgment-holds build-derivations generate-lws (struct-out derivation) (for-syntax extract-term-let-binds name-pattern-lws extract-pattern-binds check-clauses split-by-mode where-keyword? side-condition-keyword? ellipsis? visible-extras judgment-form-id? lookup-judgment-form-id)) (provide --> fresh with I O ;; macro keywords (for-syntax prune-syntax side-condition-keyword? bind-withs split-by-mode) current-traced-metafunctions (struct-out metafunc-extra-side-cond) (struct-out metafunc-extra-where) (struct-out metafunc-extra-fresh)) (provide unsupported-pat-err-name (for-syntax rewrite-terms currently-expanding-term-fn rewrite-prems with-syntax* definition-nts check-pats))