diff --git a/beautiful-racket-lib/br/experimental/eopl.rkt b/beautiful-racket-lib/br/experimental/eopl.rkt new file mode 100644 index 0000000..c5353b7 --- /dev/null +++ b/beautiful-racket-lib/br/experimental/eopl.rkt @@ -0,0 +1,97 @@ +#lang br +(require racket/struct (for-syntax br/datum)) +(provide define-datatype cases occurs-free?) + +#;(begin + (struct lc-exp () #:transparent) + + (struct var-exp lc-exp (var) #:transparent + #:guard (λ(var name) + (unless (symbol? var) + (error name (format "arg ~a not ~a" var 'symbol?))) + (values var))) + + (struct lambda-exp lc-exp (bound-var body) #:transparent + #:guard (λ(bound-var body name) + (unless (symbol? bound-var) + (error name (format "arg ~a not ~a" bound-var 'symbol?))) + (unless (lc-exp? body) + (error name (format "arg ~a not ~a" body 'lc-exp?))) + (values bound-var body))) + + (struct app-exp lc-exp (rator rand) #:transparent + #:guard (λ(rator rand name) + (unless (lc-exp? rator) + (error name (format "arg ~a not ~a" rator 'lc-exp?))) + (unless (lc-exp? rand) + (error name (format "arg ~a not ~a" rand 'lc-exp?))) + (values rator rand)))) + + +(define #'(define-datatype _base-type _base-type-predicate? + (_subtype [_field _field-predicate?] ...) ...) + #'(begin + (struct _base-type () #:transparent #:mutable) + (struct _subtype _base-type (_field ...) #:transparent #:mutable + #:guard (λ(_field ... name) + (unless (_field-predicate? _field) + (error name (format "arg ~a is not ~a" _field '_field-predicate?))) ... + (values _field ...))) ...)) + + +(define-datatype lc-exp lc-exp? + (var-exp [var symbol?]) + (lambda-exp [bound-var symbol?] [body lc-exp?]) + (app-exp [rator lc-exp?] [rand lc-exp?])) + + +#;(define (occurs-free? search-var exp) + (cond + [(var-exp? exp) (let ([var (var-exp-var exp)]) + (eqv? var search-var))] + [(lambda-exp? exp) (let ([bound-var (lambda-exp-bound-var exp)] + [body (lambda-exp-body exp)]) + (and (not (eqv? search-var bound-var)) + (occurs-free? search-var body)))] + [(app-exp? exp) (let ([rator (app-exp-rator exp)] + [rand (app-exp-rand exp)]) + (or + (occurs-free? search-var rator) + (occurs-free? search-var rand)))])) + +(define-syntax (cases stx) + (syntax-case stx (else) + [(_ _base-type _input-var + [_subtype (_positional-var ...) . _body] ... + [else . _else-body]) + (inject-syntax ([#'(_subtype? ...) (suffix-id #'(_subtype ...) "?")]) + #'(cond + [(_subtype? _input-var) (match-let ([(list _positional-var ...) (struct->list _input-var)]) + . _body)] ... + [else . _else-body]))] + [(_ _base-type _input-var + _subtype-case ...) + #'(cases _base-type _input-var + _subtype-case ... + [else (void)])])) + + +(define (occurs-free? search-var exp) + (cases lc-exp exp + [var-exp (var) (eqv? var search-var)] + [lambda-exp (bound-var body) + (and (not (eqv? search-var bound-var)) + (occurs-free? search-var body))] + [app-exp (rator rand) + (or + (occurs-free? search-var rator) + (occurs-free? search-var rand))])) + + +(module+ test + (require rackunit) + (check-true (occurs-free? 'foo (var-exp 'foo))) + (check-false (occurs-free? 'foo (var-exp 'bar))) + (check-false (occurs-free? 'foo (lambda-exp 'foo (var-exp 'bar)))) + (check-true (occurs-free? 'foo (lambda-exp 'bar (var-exp 'foo)))) + (check-true (occurs-free? 'foo (lambda-exp 'bar (lambda-exp 'zim (lambda-exp 'zam (var-exp 'foo))))))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/experimental/load.rkt b/beautiful-racket-lib/br/experimental/load.rkt new file mode 100644 index 0000000..c1e39fc --- /dev/null +++ b/beautiful-racket-lib/br/experimental/load.rkt @@ -0,0 +1,26 @@ +#lang racket +(provide (except-out (all-from-out racket) #%module-begin) + (rename-out [loader-module-begin #%module-begin])) + +#| + +br/load makes it possible to invoke a quick #lang by its pathname (without installing it as a collection) + +#lang br/load "path.rkt" + +Should simply delegate the reader & semantics. + +|# + +(define-syntax-rule (loader-module-begin loadpath expr ...) + (#%module-begin + (module loader-module loadpath + expr ...) + (require 'loader-module) + + (module reader racket/base + (require '(submod loadpath reader)) + (provide (all-from-out '(submod loadpath reader)))))) + +(module reader syntax/module-reader + br/load) \ No newline at end of file diff --git a/beautiful-racket-lib/br/scope.rkt b/beautiful-racket-lib/br/experimental/scope.rkt similarity index 100% rename from beautiful-racket-lib/br/scope.rkt rename to beautiful-racket-lib/br/experimental/scope.rkt diff --git a/beautiful-racket-lib/br/experimental/stxparam.rkt b/beautiful-racket-lib/br/experimental/stxparam.rkt new file mode 100644 index 0000000..c6b1ab7 --- /dev/null +++ b/beautiful-racket-lib/br/experimental/stxparam.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require (for-syntax racket/base) racket/stxparam racket/splicing) +(provide splicing-syntax-parameterize + define-syntax-parameters + define-language-variables + define-language-variable + inject-language-variables + (rename-out [br:define-syntax-parameter define-syntax-parameter])) + +(define-syntax (br:define-syntax-parameter stx) + (syntax-case stx () + [(_ ID STX) #'(define-syntax-parameter ID STX)] + [(_ [ID VAL]) #'(define-syntax-parameter ID (λ (stx) #'VAL))] + [(_ ID) #'(define-syntax-parameter ID + (λ (stx) (raise-syntax-error (syntax-e stx) "parameter not set")))])) + +(define-syntax-rule (define-syntax-parameters ID ...) + (begin (br:define-syntax-parameter ID) ...)) + +(define-syntax-rule (define-language-variable ID VAL) + (br:define-syntax-parameter [ID VAL])) + +(define-syntax-rule (define-language-variables [ID VAL] ...) + (begin (define-language-variable ID VAL) ...)) + +(define-syntax (inject-language-variables stx) + (syntax-case stx () + [(_ (VAR-PARAM ...) LANG-CODE ...) + (with-syntax ([(HOLDS-ORIG-PARAM-VALUE ...) (generate-temporaries #'(VAR-PARAM ...))] + [(INTERNAL-NAME ...) (generate-temporaries #'(VAR-PARAM ...))]) + ;; need to use splicing expressions in a module-begin to compose with requires etc. that might be in lang code + #'(splicing-let ([HOLDS-ORIG-PARAM-VALUE VAR-PARAM] ...) + (splicing-syntax-parameterize + ([VAR-PARAM (make-rename-transformer #'INTERNAL-NAME)] ...) + (define INTERNAL-NAME HOLDS-ORIG-PARAM-VALUE) ... + (provide (rename-out [INTERNAL-NAME VAR-PARAM] ...)) + LANG-CODE ...)))])) diff --git a/beautiful-racket-lib/br/to-string.rkt b/beautiful-racket-lib/br/private/to-string.rkt similarity index 100% rename from beautiful-racket-lib/br/to-string.rkt rename to beautiful-racket-lib/br/private/to-string.rkt diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index e8bac8d..b493e7f 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -1,6 +1,6 @@ #lang racket/base (require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context) - syntax/strip-context racket/function racket/list racket/syntax br/to-string) + syntax/strip-context racket/function racket/list racket/syntax "private/to-string.rkt") (provide (all-defined-out) (all-from-out syntax/strip-context) (rename-out [strip-context strip-identifier-bindings]))