From 1d67cbe65e05d5f1c0f9a01ac360c3527e9254d5 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 22 Mar 2018 09:01:07 +1300 Subject: [PATCH] Rearrange --- syndicate/pattern-test.rkt | 47 ------------------------- syndicate/pattern.rkt | 7 +++- syndicate/{main.rkt => prototype.rkt} | 0 syndicate/test/pattern-test.rkt | 50 +++++++++++++++++++++++++++ 4 files changed, 56 insertions(+), 48 deletions(-) delete mode 100644 syndicate/pattern-test.rkt rename syndicate/{main.rkt => prototype.rkt} (100%) create mode 100644 syndicate/test/pattern-test.rkt diff --git a/syndicate/pattern-test.rkt b/syndicate/pattern-test.rkt deleted file mode 100644 index 87e1555..0000000 --- a/syndicate/pattern-test.rkt +++ /dev/null @@ -1,47 +0,0 @@ -#lang racket/base - -(require rackunit) - -(require (for-syntax racket/base)) -(require (for-syntax "pattern.rkt")) -(require "pattern.rkt") - -(struct foo (bar zot) #:prefab) - -(define-syntax (check-analyse-pattern stx) - (syntax-case stx () - [(_ expected-pat actual-stxpat fn) - #`(check-match (fn '#,(analyse-pattern #'actual-stxpat)) expected-pat)] - [(_ expected-pat actual-stxpat) - #'(check-analyse-pattern expected-pat actual-stxpat values)])) - -(check-analyse-pattern `(compound ,_ (atom 123) (atom 234)) (foo 123 234)) -(check-analyse-pattern `(compound ,_ (discard) (atom 234)) (foo _ 234)) -(check-analyse-pattern `(compound ,_ (atom 123) (atom xyzzy)) (foo 123 xyzzy)) -(check-analyse-pattern `(compound ,_ (atom 123) (capture cap (discard))) (foo 123 $cap)) -(check-analyse-pattern `(compound ,_ (atom 123) (capture cap (atom 234))) (foo 123 ($ cap 234))) - -(check-analyse-pattern `(atom (bar 123 234)) (bar 123 234)) -(check-analyse-pattern `(atom (bar 123 $beep)) (bar 123 $beep)) - -(check-analyse-pattern `(compound list (atom 123) (capture q (discard))) (list 123 $q)) - -(define ((s->d f) desc) (syntax->datum (f desc))) - -(check-analyse-pattern '() $cap desc->key) -(check-analyse-pattern '() $cap desc->skeleton-proj) -(check-analyse-pattern '((0)) $cap desc->capture-proj) -(check-analyse-pattern '#f $cap (s->d desc->skeleton-stx)) -(check-analyse-pattern '? $cap (s->d desc->assertion-stx)) - -(check-analyse-pattern '(123) (foo 123 $cap) desc->key) -(check-analyse-pattern '((0 0)) (foo 123 $cap) desc->skeleton-proj) -(check-analyse-pattern '((0 1)) (foo 123 $cap) desc->capture-proj) -(check-analyse-pattern '(list foo? #f #f) (foo 123 $cap) (s->d desc->skeleton-stx)) -(check-analyse-pattern '(foo 123 ?) (foo 123 $cap) (s->d desc->assertion-stx)) - -(check-analyse-pattern '((bar 'beep)) (foo (bar 'beep) $cap) desc->key) -(check-analyse-pattern '((0 0)) (foo (bar 'beep) $cap) desc->skeleton-proj) -(check-analyse-pattern '((0 1)) (foo (bar 'beep) $cap) desc->capture-proj) -(check-analyse-pattern '(list foo? #f #f) (foo (bar 'beep) $cap) (s->d desc->skeleton-stx)) -(check-analyse-pattern '(foo (bar 'beep) ?) (foo (bar 'beep) $cap) (s->d desc->assertion-stx)) diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt index 35c27cd..e438dc8 100644 --- a/syndicate/pattern.rkt +++ b/syndicate/pattern.rkt @@ -1,6 +1,11 @@ #lang racket/base -(provide (all-defined-out)) +(provide analyse-pattern + desc->key + desc->skeleton-proj + desc->capture-proj + desc->skeleton-stx + desc->assertion-stx) (require racket/match) (require racket/struct-info) diff --git a/syndicate/main.rkt b/syndicate/prototype.rkt similarity index 100% rename from syndicate/main.rkt rename to syndicate/prototype.rkt diff --git a/syndicate/test/pattern-test.rkt b/syndicate/test/pattern-test.rkt new file mode 100644 index 0000000..808888f --- /dev/null +++ b/syndicate/test/pattern-test.rkt @@ -0,0 +1,50 @@ +#lang racket/base + +(module+ test + (require rackunit) + + (require (for-syntax racket/base)) + (require (for-syntax "pattern.rkt")) + (require "pattern.rkt") + + (struct foo (bar zot) #:prefab) + + (define-syntax (check-analyse-pattern stx) + (syntax-case stx () + [(_ expected-pat actual-stxpat fn) + #`(check-match (fn '#,(analyse-pattern #'actual-stxpat)) expected-pat)] + [(_ expected-pat actual-stxpat) + #'(check-analyse-pattern expected-pat actual-stxpat values)])) + + (check-analyse-pattern `(compound ,_ (atom 123) (atom 234)) (foo 123 234)) + (check-analyse-pattern `(compound ,_ (discard) (atom 234)) (foo _ 234)) + (check-analyse-pattern `(compound ,_ (atom 123) (atom xyzzy)) (foo 123 xyzzy)) + (check-analyse-pattern `(compound ,_ (atom 123) (capture cap (discard))) (foo 123 $cap)) + (check-analyse-pattern `(compound ,_ (atom 123) (capture cap (atom 234))) (foo 123 ($ cap 234))) + + (check-analyse-pattern `(atom (bar 123 234)) (bar 123 234)) + (check-analyse-pattern `(atom (bar 123 $beep)) (bar 123 $beep)) + + (check-analyse-pattern `(compound list (atom 123) (capture q (discard))) (list 123 $q)) + + (define ((s->d f) desc) (syntax->datum (f desc))) + + (check-analyse-pattern '() $cap desc->key) + (check-analyse-pattern '() $cap desc->skeleton-proj) + (check-analyse-pattern '((0)) $cap desc->capture-proj) + (check-analyse-pattern '#f $cap (s->d desc->skeleton-stx)) + (check-analyse-pattern '? $cap (s->d desc->assertion-stx)) + + (check-analyse-pattern '(123) (foo 123 $cap) desc->key) + (check-analyse-pattern '((0 0)) (foo 123 $cap) desc->skeleton-proj) + (check-analyse-pattern '((0 1)) (foo 123 $cap) desc->capture-proj) + (check-analyse-pattern '(list foo? #f #f) (foo 123 $cap) (s->d desc->skeleton-stx)) + (check-analyse-pattern '(foo 123 ?) (foo 123 $cap) (s->d desc->assertion-stx)) + + (check-analyse-pattern '((bar 'beep)) (foo (bar 'beep) $cap) desc->key) + (check-analyse-pattern '((0 0)) (foo (bar 'beep) $cap) desc->skeleton-proj) + (check-analyse-pattern '((0 1)) (foo (bar 'beep) $cap) desc->capture-proj) + (check-analyse-pattern '(list foo? #f #f) (foo (bar 'beep) $cap) (s->d desc->skeleton-stx)) + (check-analyse-pattern '(foo (bar 'beep) ?) (foo (bar 'beep) $cap) (s->d desc->assertion-stx)) + + )