vendor in ee-lib; will be developed here now

design/staged-minikanren.rkt

@@ -5,12 +5,12 @@
          (for-space mk quasiquote))
 
 (require "../main.rkt"
-         ee-lib/errors
+         "../private/ee-lib/errors.rkt"
          (for-syntax
           racket/base
           syntax/parse
           syntax/id-table
-          (except-in ee-lib racket-var)))
+          (except-in "../private/ee-lib/main.rkt" racket-var)))
 
 ;;
 ;; Core syntax

info.rkt

@@ -6,7 +6,6 @@
 (define license '(Apache-2.0 OR MIT))
 (define deps '("base"
                "version-case"
-               "ee-lib"
                "syntax-classes-lib"
                "rackunit-lib"))
 (define build-deps '("racket-doc" "scribble-lib" "drracket"))

main.rkt

@@ -23,8 +23,8 @@
 (require "private/syntax/interface.rkt"
          "private/runtime/compile.rkt"
          (for-syntax syntax/parse
-                     (except-in ee-lib racket-var)
-                     ee-lib/persistent-id-table
-                     ee-lib/private/binding
+                     (except-in "private/ee-lib/main.rkt" racket-var)
+                     "private/ee-lib/persistent-id-table.rkt"
+                     "private/ee-lib/binding.rkt"
                      "private/runtime/binding-operations.rkt"
                      "private/runtime/syntax-classes.rkt"))

private/ee-lib/binding.rkt

@@ -0,0 +1,75 @@
+#lang racket/base
+
+(provide identifier-has-binding?
+         identifier-with-binding?
+         same-binding?
+         top-binding?
+         module-or-top-binding?
+         maybe-raise-ambiguity-error)
+
+(require racket/private/check
+         "flip-intro-scope.rkt")
+
+(define/who (identifier-has-binding? id)
+  (check who identifier? id)
+
+  (not (not (identifier-binding id (syntax-local-phase-level) #t))))
+
+(define (identifier-with-binding? val)
+  (and (identifier? val) (identifier-has-binding? val)))
+
+(define/who (same-binding? id1 id2)
+  (check who identifier? id1)
+  (check who identifier? id2)
+
+  (maybe-raise-ambiguity-error id1)
+  (maybe-raise-ambiguity-error id2)
+
+  (let ([id1-ext (if (syntax-transforming?) (flip-intro-scope id1) id1)]
+        [id2-ext (if (syntax-transforming?) (flip-intro-scope id2) id2)])
+
+    (and (identifier-has-binding? id1-ext)
+         (identifier-has-binding? id2-ext)
+         (free-identifier=? id1-ext id2-ext))))
+
+(define/who (top-binding? id)
+  (check who identifier-with-binding? id)
+
+  (define binding
+    (identifier-binding id (syntax-local-phase-level) #t))
+
+  (and (list? binding) (= 1 (length binding))))
+
+(define/who (module-or-top-binding? id)
+  (check who identifier-with-binding? id)
+
+  (define binding
+    (identifier-binding id (syntax-local-phase-level) #t))
+  (list? binding))
+
+;; situation         ; identifier-binding  ; syntax-local-value  ; syntax-debug-info
+;; bound as syntax   ; non-#f value        ; environment value   ; has matching binding(s)
+
+;; note: the following two cases can't be easily distinguished; this is why `lookup`
+;;   never tells you a name is unbound or out-of-context, and instead can only tell you
+;;   that it isn't bound to the particular kind of syntax you check via the predicate.
+;; bound as racket   ; non-#f value        ; fails               ; has matching binding(s)
+;; out of context    ; non-#f value        ; fails               ; has matching binding(s)
+
+;; unbound           ; #f                  ; fails               ; no matching bindings (I hope!)
+;; ambiguous         ; #f                  ; fails               ; has matching binding(s)
+(define (maybe-raise-ambiguity-error id)
+  (define (has-matching-bindings? id)
+    (define debug-info (syntax-debug-info (if (syntax-transforming?) (flip-intro-scope id) id)))
+    (and
+     (hash-has-key? debug-info 'bindings)
+     (let* ([bindings (hash-ref debug-info 'bindings)]
+            [matching-bindings (filter (lambda (b) (hash-ref b 'match?)) bindings)])
+         (not (null? matching-bindings)))))
+
+  (when (and (not (identifier-binding id (syntax-local-phase-level) #t))
+             (has-matching-bindings? id))
+    ;; have racket raise the error by local-expanding
+    (if (syntax-transforming?)
+        (local-expand id 'expression '())
+        (error 'maybe-raise-ambiguity-error "internal error: don't know how to raise ambiguity error"))))

private/ee-lib/datum-map.rkt

@@ -0,0 +1,109 @@
+#lang racket/base
+
+(provide datum-map)
+
+;; datum-map copied from the Racket expander:
+;;    syntax/datum-map.rkt
+
+(require racket/fixnum racket/prefab)
+
+;; `(datum-map v f)` walks over `v`, traversing objects that
+;; `datum->syntax` traverses to convert content to syntax objects.
+;; 
+;; `(f tail? d)` is called on each datum `d`, where `tail?`
+;; indicates that the value is a pair/null in a `cdr` --- so that it
+;; doesn't need to be wrapped for `datum->syntax`, for example;
+;; the `tail?` argument is actually #f or a fixnum for a lower bound
+;; on `cdr`s that have been taken
+;;
+;; `gf` is like `f`, but `gf` is used when the argument might be
+;; syntax; if `gf` is provided, `f` can assume that its argument
+;; is not syntax
+;;
+;; If a `seen` argument is provided, then it should be an `eq?`-based
+;; hash table, and cycle checking is enabled; when a cycle is
+;; discovered, the procedure attached to 'cycle-fail in the initial
+;; table is called
+;;
+;; If a `known-pairs` argument is provided, then it should be an
+;; `eq?`-based hash table to map pairs that can be returned as-is
+;; in a `tail?` position
+
+;; The inline version uses `f` only in an application position to
+;; help avoid allocating a closure. It also covers only the most common
+;; cases, defering to the general (not inlined) function for other cases.
+(define (datum-map s f [gf f] [seen #f] [known-pairs #f])
+  (let loop ([tail? #f] [s s] [prev-depth 0])
+    (define depth (fx+ 1 prev-depth)) ; avoid cycle-checking overhead for shallow cases
+    (cond
+      [(and seen (depth . fx> . 32))
+       (datum-map-slow tail? s  (lambda (tail? s) (gf tail? s)) seen known-pairs)]
+      [(null? s) (f tail? s)]
+      [(pair? s)
+       (f tail? (cons (loop #f (car s) depth)
+                      (loop 1 (cdr s) depth)))]
+      [(symbol? s) (f #f s)]
+      [(boolean? s) (f #f s)]
+      [(number? s) (f #f s)]
+      [(or (vector? s) (box? s) (prefab-struct-key s) (hash? s))
+       (datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen known-pairs)]
+      [else (gf #f s)])))
+
+(define (datum-map-slow tail? s f seen known-pairs)
+  (let loop ([tail? tail?] [s s] [prev-seen seen])
+    (define seen
+      (cond
+        [(and prev-seen (datum-has-elements? s))
+         (cond
+           [(hash-ref prev-seen s #f)
+            ((hash-ref prev-seen 'cycle-fail) s)]
+           [else (hash-set prev-seen s #t)])]
+        [else prev-seen]))
+    (cond
+      [(null? s) (f tail? s)]
+      [(pair? s)
+       (cond
+         [(and known-pairs
+               tail?
+               (hash-ref known-pairs s #f))
+          s]
+         [else
+          (f tail? (cons (loop #f (car s) seen)
+                         (loop (if tail? (fx+ 1 tail?) 1)  (cdr s) seen)))])]
+      [(or (symbol? s) (boolean? s) (number? s))
+       (f #f s)]
+      [(vector? s)
+       (f #f (vector->immutable-vector
+              (for/vector #:length (vector-length s) ([e (in-vector s)])
+                (loop #f e seen))))]
+      [(box? s)
+       (f #f (box-immutable (loop #f (unbox s) seen)))]
+      [(immutable-prefab-struct-key s)
+       => (lambda (key)
+            (f #f
+               (apply make-prefab-struct
+                      key
+                      (for/list ([e (in-vector (struct->vector s) 1)])
+                        (loop #f e seen)))))]
+      [(and (hash? s) (immutable? s))
+       (cond
+         [(hash-eq? s)
+          (f #f
+             (for/hasheq ([(k v) (in-hash s)])
+               (values k (loop #f v seen))))]
+         [(hash-eqv? s)
+          (f #f
+             (for/hasheqv ([(k v) (in-hash s)])
+               (values k (loop #f v seen))))]
+         [else
+          (f #f
+             (for/hash ([(k v) (in-hash s)])
+               (values k (loop #f v seen))))])]
+      [else (f #f s)])))
+
+(define (datum-has-elements? d)
+  (or (pair? d)
+      (vector? d)
+      (box? d)
+      (immutable-prefab-struct-key d)
+      (and (hash? d) (immutable? d) (positive? (hash-count d)))))

private/ee-lib/define.rkt

@@ -0,0 +1,85 @@
+#lang racket/base
+
+(require
+  (for-syntax
+   racket/base
+   (rename-in syntax/parse [define/syntax-parse def/stx])
+   racket/syntax
+   racket/generic
+   "main.rkt"
+   "syntax-category.rkt"))
+
+(provide
+ define-literal-forms
+ define-extensible-syntax)
+
+(begin-for-syntax
+  (define-syntax-class symbol
+    (pattern stx:id
+      #:attr sym (syntax-e (attribute stx))))
+  (struct literal-rep [msg]
+    #:property prop:procedure (lambda (s stx) (raise-syntax-error #f (literal-rep-msg s) stx))
+    #:property prop:not-racket-syntax #t))
+
+(define-syntax define-literal-forms
+  (module-macro
+   (syntax-parser
+     [(_ literal-set-name:id
+         (~optional (~seq #:syntax-class syntax-class-name:id))
+         (~optional (~seq #:binding-space (~or space:symbol #f)))
+         msg:string (name:id ...))
+      #:with (spaced-name ...) (map (in-space (attribute space.sym)) (attribute name))
+      #'(begin
+          (define-syntax spaced-name (literal-rep 'msg))
+          ...
+          (begin-for-syntax
+            (define-literal-set literal-set-name
+              (spaced-name ...))
+            (~? (define-syntax-class syntax-class-name
+                  #:literal-sets (literal-set-name)
+                  (pattern (~or spaced-name ...)))
+                (begin))))])))
+
+(require (for-syntax syntax/parse/private/sc))
+
+(begin-for-syntax
+  (define (make-extension-definition-transformer rep-constructor)
+    (syntax-parser
+      [(_ name:id rhs)
+       #`(define-syntax name (#,rep-constructor rhs))]))
+
+  (define-syntax-class head
+    (pattern (name:id . rest)
+      #:attr pat #'((~var name id) . rest))
+    (pattern name:id
+      #:attr pat #'(~var name id)))
+
+  (define (make-simple-macro-definition-transformer define-form)
+    (syntax-parser
+      [(_ h:head . body)
+       #`(#,define-form h.name
+                        (syntax-parser/template
+                         #,((make-syntax-introducer) this-syntax)
+                         [h.pat . body]))])))
+
+(define-syntax define-extensible-syntax
+  (module-macro
+   (syntax-parser
+     [(_ name)
+      (def/stx gen-name (format-id #'name "gen:~a" #'name))
+      (def/stx name-transform (format-id #'name "~a-transform" #'name))
+      (def/stx name-rep (format-id #'name "~a-rep" #'name))
+      (def/stx name-rep-procedure (format-id #'name "~a-rep-procedure" #'name))
+      (def/stx define-name (format-id #'name "define-~a" #'name))
+      (def/stx define-simple-name (format-id #'name "define-simple-~a" #'name))
+      #'(begin
+          (begin-for-syntax
+            (define-generics name
+              (name-transform name stx))
+            (struct name-rep (procedure)
+              #:methods gen-name
+              [(define (name-transform s stx)
+                 ((name-rep-procedure s) stx))]))
+          (define-syntax define-name (make-extension-definition-transformer #'name-rep))
+          (define-syntax define-simple-name
+            (make-simple-macro-definition-transformer #'define-name)))])))

private/ee-lib/errors.rkt

@@ -0,0 +1,30 @@
+#lang racket/base
+
+(provide raise-argument-error/stx (struct-out exn:fail:contract:srcloc))
+
+(define-struct (exn:fail:contract:srcloc
+                exn:fail:contract)
+  (srcloc)
+  #:property prop:exn:srclocs
+  (lambda (s)
+    (list (exn:fail:contract:srcloc-srcloc s))))
+
+(define (syntax->srcloc blame-stx)
+  (srcloc
+   (syntax-source blame-stx)
+   (syntax-line blame-stx)
+   (syntax-column blame-stx)
+   (syntax-position blame-stx)
+   (syntax-span blame-stx)))
+
+(define (raise-argument-error/stx name expected v stx)
+  (raise (exn:fail:contract:srcloc
+          (format "~a: ~a: contract violation\n  expected: ~a\n  given:  ~a"
+                  (srcloc->string (syntax->srcloc stx))
+                  name
+                  expected
+                  v)
+          (current-continuation-marks)
+          (syntax->srcloc stx))))
+
+

private/ee-lib/flip-intro-scope.rkt

@@ -0,0 +1,19 @@
+#lang racket/base
+
+(provide flip-intro-scope)
+
+(require racket/private/check)
+
+(define (make-intro-scope-introducer)
+  (define no-scope (datum->syntax #f 'foo))
+  (define intro-scope
+    (syntax-local-identifier-as-binding
+     (syntax-local-introduce
+      no-scope)))
+  (make-syntax-delta-introducer
+   intro-scope
+   no-scope))
+
+(define/who (flip-intro-scope stx)
+  (check who syntax? stx)
+  ((make-intro-scope-introducer) stx 'flip))