From 86930702e00ecb8cb32edeb97472962b8a0690f6 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 21 Mar 2018 19:01:46 +1300 Subject: [PATCH] Initial sketch of new routing-table idea --- syndicate/main.rkt | 266 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 266 insertions(+) create mode 100644 syndicate/main.rkt diff --git a/syndicate/main.rkt b/syndicate/main.rkt new file mode 100644 index 0000000..6a5f111 --- /dev/null +++ b/syndicate/main.rkt @@ -0,0 +1,266 @@ +#lang racket/base + +(provide (all-defined-out)) + +(require syndicate/support/struct) +(require racket/match) +(require racket/set) +(require racket/list) +(require racket/hash) + +(require (for-syntax racket/base)) +(require (for-syntax syntax/stx)) + +(module+ test (require rackunit)) + +;; A `SkProj` is a *skeleton projection*, a specification of loci +;; within a tree-shaped datum to collect into a flat list. +;; +;; SkProj = (Listof (Listof Nat)) +;; +;; The outer list specifies elements of the flat list; the inner lists +;; specify paths via zero-indexed links to child nodes in the +;; tree-shaped datum being examined. A precondition for use of a +;; `SkProj` is that the datum being examined has been checked for +;; conformance to the skeleton being projected. + +;; A `SkKey` is the result of running a `SkProj` over a term, +;; extracting the values at the denoted locations. + +;; A `SkCont` is a *skeleton continuation*, a collection of "next +;; steps" after a `Skeleton` has matched the general outline of a +;; datum. +;; +;; SkCont = (MutableHash SkProj (MutableHash SkKey (MutableHash SkProj (Setof (... -> Any))))) +;; +;; The outer `SkProj` selects *constant* portions of the term for more +;; matching against the `SkKey`s in the hash table. The inner +;; `SkProj`, if any, selects *variable* portions of the term to be +;; given to the handler function. + +;; A `Skeleton` is a structural guard on a datum: essentially, +;; specification of (the outline of) its shape; its silhouette. +;; +;; Skeleton = (skeleton-node SkCont (AListof SkLabel SkNode)) +;; SkLabel = (skeleton-edge Nat Nat SkClass Nat) +;; SkClass = StructType | 'list +;; +(struct skeleton-node (continuations [edges #:mutable]) #:transparent) +(struct skeleton-edge (pop-count index class arity) #:transparent) + +(define (make-empty-skeleton) + (skeleton-node (make-hash) '())) + +(define (select-pattern-leaves stx capture-fn atom-fn) + (define (walk-node key-rev stx) + (match stx + [(list pieces ...) (walk-edge 0 key-rev pieces)] + ['$ (capture-fn key-rev)] + ['_ (list)] + [atom (atom-fn key-rev atom)])) + (define (walk-edge index key-rev pieces) + (match pieces + ['() '()] + [(cons p pieces) (append (walk-node (cons index key-rev) p) + (walk-edge (+ index 1) key-rev pieces))])) + (walk-node '(0) stx)) + +(define (pattern-stx->key stx) + (select-pattern-leaves stx + (lambda (_key-rev) (list)) + (lambda (_key-rev atom) (list atom)))) + +(define (pattern-stx->skeleton-proj stx) + (select-pattern-leaves stx + (lambda (_key-rev) (list)) + (lambda (key-rev _atom) (list (reverse key-rev))))) + +(define (pattern-stx->capture-proj stx) + (select-pattern-leaves stx + (lambda (key-rev) (list (reverse key-rev))) + (lambda (_key-rev _atom) (list)))) + +(define merge-skcont! + (let () + (define (merge-proj-handler old new) + (hash-union! old new #:combine set-union)) + (define (merge-key-proj-handler old new) + (hash-union! old new #:combine merge-proj-handler)) + (lambda (old new) + (hash-union! old new #:combine merge-key-proj-handler)))) + +;; Imperatively extends `sk` to include the pattern `stx` terminating +;; in `skcont`. +(define (extend-skeleton! sk skcont stx) + (define (walk-node! sk pop-count index stx) + (match stx + [(list pieces ...) + (define edge (skeleton-edge pop-count index 'list (length pieces))) + (define next + (match (assoc edge (skeleton-node-edges sk)) + [#f (let ((next (make-empty-skeleton))) + (set-skeleton-node-edges! sk (cons (cons edge next) (skeleton-node-edges sk))) + next)] + [(cons _edge next) next])) + (walk-edge! next 0 0 pieces)] + [_ + (values pop-count sk)])) + (define (walk-edge! sk pop-count index pieces) + (match pieces + ['() + (values (+ pop-count 1) sk)] + [(cons p pieces) + (let-values (((pop-count sk) (walk-node! sk pop-count index p))) + (walk-edge! sk pop-count (+ index 1) pieces))])) + (let-values (((_pop-count sk) (walk-edge! sk 0 0 (list stx)))) + (merge-skcont! (skeleton-node-continuations sk) skcont) + sk)) + +;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj` +(define (apply-projection term proj) + (for/list [(path proj)] + (for/fold [(term (list term))] [(index path)] + (cond [(list? term) (list-ref term index)] + [else (error 'apply-projection "Non-lists not supported: ~v" term)])))) + +(module+ test + (define stx0 '$) + (define stx1 '3) + (define stxA '($ 3)) + (define stxB '(4 $)) + (define stxC '(_ ($ $))) + (define stxD '(_ (1 2))) + (define stxE '((6 6) _)) + (define stxF '(($ $) (3 9))) + (define stxG '((_ _) (1 2))) + (define stxH '((_ _) ((_ _) ($ _)))) + (define stxI '(((_ _) _) (_ _))) + (define stxJ '(((_ _) (_ _)) (_ _))) + + (define (summarise-skeleton sk) + (define (walk-node sk) + (match-define (skeleton-node continuations edges) sk) + (append (if (hash-empty? continuations) '() (list continuations)) + (map walk-edge edges))) + (define (walk-edge e) + (match-define (cons (skeleton-edge pop-count index class arity) sk) e) + (for/fold [(acc (list* (list index class arity) (walk-node sk)))] + [(n pop-count)] + (list 'POP acc))) + (walk-node sk)) + + (define (skcont . ids) + (define acc (make-hash)) + ;; Not quite the right shape! Just a dummy placeholder for testing + (for [(id ids)] + (merge-skcont! acc + (make-hash + (list (cons id (make-hash + (list (cons id (make-hash + (list (cons id (set)))))))))))) + acc) + + (define (skeleton-stx->skeleton id pat-stx) + (define sk (make-empty-skeleton)) + (extend-skeleton! sk (skcont id) pat-stx) + sk) + + (check-equal? `(,(skcont 0)) + (summarise-skeleton (skeleton-stx->skeleton '0 stx0))) + (check-equal? `(,(skcont 1)) + (summarise-skeleton (skeleton-stx->skeleton '1 stx1))) + (check-equal? `(((0 list 2) ,(skcont 'A))) + (summarise-skeleton (skeleton-stx->skeleton 'A stxA))) + (check-equal? `(((0 list 2) ,(skcont 'B))) + (summarise-skeleton (skeleton-stx->skeleton 'B stxB))) + (check-equal? `(((0 list 2) ((1 list 2) ,(skcont 'C)))) + (summarise-skeleton (skeleton-stx->skeleton 'C stxC))) + (check-equal? `(((0 list 2) ((1 list 2) ,(skcont 'D)))) + (summarise-skeleton (skeleton-stx->skeleton 'D stxD))) + (check-equal? `(((0 list 2) ((0 list 2) ,(skcont 'E)))) + (summarise-skeleton (skeleton-stx->skeleton 'E stxE))) + (check-equal? `(((0 list 2) ((0 list 2) (POP ((1 list 2) ,(skcont 'F)))))) + (summarise-skeleton (skeleton-stx->skeleton 'F stxF))) + (check-equal? `(((0 list 2) ((0 list 2) (POP ((1 list 2) ,(skcont 'G)))))) + (summarise-skeleton (skeleton-stx->skeleton 'G stxG))) + (check-equal? `(((0 list 2) + ((0 list 2) (POP ((1 list 2) ((0 list 2) (POP ((1 list 2) ,(skcont 'H))))))))) + (summarise-skeleton (skeleton-stx->skeleton 'H stxH))) + (check-equal? `(((0 list 2) ((0 list 2) ((0 list 2) (POP (POP ((1 list 2) ,(skcont 'I)))))))) + (summarise-skeleton (skeleton-stx->skeleton 'I stxI))) + (check-equal? `(((0 list 2) + ((0 list 2) + ((0 list 2) (POP ((1 list 2) (POP (POP ((1 list 2) ,(skcont 'J)))))))))) + (summarise-skeleton (skeleton-stx->skeleton 'J stxJ))) + + (check-equal? `(,(skcont 0 1) + ((0 list 2) + ,(skcont 'A 'B) + ((0 list 2) + ,(skcont 'E) + ((0 list 2) + (POP ((1 list 2) (POP (POP ((1 list 2) ,(skcont 'J)))))) + (POP (POP ((1 list 2) ,(skcont 'I))))) + (POP ((1 list 2) ,(skcont 'F 'G) ((0 list 2) (POP ((1 list 2) ,(skcont 'H))))))) + ((1 list 2) ,(skcont 'C 'D)))) + (let ((sk (make-empty-skeleton))) + (extend-skeleton! sk (skcont '0) stx0) + (extend-skeleton! sk (skcont '1) stx1) + (extend-skeleton! sk (skcont 'A) stxA) + (extend-skeleton! sk (skcont 'B) stxB) + (extend-skeleton! sk (skcont 'C) stxC) + (extend-skeleton! sk (skcont 'D) stxD) + (extend-skeleton! sk (skcont 'E) stxE) + (extend-skeleton! sk (skcont 'F) stxF) + (extend-skeleton! sk (skcont 'G) stxG) + (extend-skeleton! sk (skcont 'H) stxH) + (extend-skeleton! sk (skcont 'I) stxI) + (extend-skeleton! sk (skcont 'J) stxJ) + (summarise-skeleton sk))) + + (check-equal? '() (pattern-stx->skeleton-proj stx0)) + (check-equal? '((0)) (pattern-stx->skeleton-proj stx1)) + (check-equal? '((0 1)) (pattern-stx->skeleton-proj stxA)) + (check-equal? '((0 0)) (pattern-stx->skeleton-proj stxB)) + (check-equal? '() (pattern-stx->skeleton-proj stxC)) + (check-equal? '((0 1 0) (0 1 1)) (pattern-stx->skeleton-proj stxD)) + (check-equal? '((0 0 0) (0 0 1)) (pattern-stx->skeleton-proj stxE)) + (check-equal? '((0 1 0) (0 1 1)) (pattern-stx->skeleton-proj stxF)) + (check-equal? '((0 1 0) (0 1 1)) (pattern-stx->skeleton-proj stxG)) + (check-equal? '() (pattern-stx->skeleton-proj stxH)) + (check-equal? '() (pattern-stx->skeleton-proj stxI)) + (check-equal? '() (pattern-stx->skeleton-proj stxJ)) + + (check-equal? '() (pattern-stx->key stx0)) + (check-equal? '(3) (pattern-stx->key stx1)) + (check-equal? '(3) (pattern-stx->key stxA)) + (check-equal? '(4) (pattern-stx->key stxB)) + (check-equal? '() (pattern-stx->key stxC)) + (check-equal? '(1 2) (pattern-stx->key stxD)) + (check-equal? '(6 6) (pattern-stx->key stxE)) + (check-equal? '(3 9) (pattern-stx->key stxF)) + (check-equal? '(1 2) (pattern-stx->key stxG)) + (check-equal? '() (pattern-stx->key stxH)) + (check-equal? '() (pattern-stx->key stxI)) + (check-equal? '() (pattern-stx->key stxJ)) + + (check-equal? '((0)) (pattern-stx->capture-proj stx0)) + (check-equal? '() (pattern-stx->capture-proj stx1)) + (check-equal? '((0 0)) (pattern-stx->capture-proj stxA)) + (check-equal? '((0 1)) (pattern-stx->capture-proj stxB)) + (check-equal? '((0 1 0) (0 1 1)) (pattern-stx->capture-proj stxC)) + (check-equal? '() (pattern-stx->capture-proj stxD)) + (check-equal? '() (pattern-stx->capture-proj stxE)) + (check-equal? '((0 0 0) (0 0 1)) (pattern-stx->capture-proj stxF)) + (check-equal? '() (pattern-stx->capture-proj stxG)) + (check-equal? '((0 1 1 0)) (pattern-stx->capture-proj stxH)) + (check-equal? '() (pattern-stx->capture-proj stxI)) + (check-equal? '() (pattern-stx->capture-proj stxJ)) + + (check-equal? '(goodbye hello) + (apply-projection '((goodbye hello) (3 9)) (pattern-stx->capture-proj stxF))) + (check-equal? '(99) + (apply-projection '(4 99) (pattern-stx->capture-proj stxB))) + (check-equal? '((4 99)) + (apply-projection '(4 99) (pattern-stx->capture-proj stx0))) + )