suzanne.soy/remix
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adding parents

Browse Source
This commit is contained in:
Jay McCarthy 2015-12-01 15:12:28 -05:00
parent 1e82bd68e9
commit 39041fae09
2 changed files with 72 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
remix/data0.rkt
View File

@ -1,11 +1,13 @@
#lang racket/base #lang racket/base
(require (for-syntax (require (for-syntax
racket/base racket/base
syntax/quote
syntax/parse syntax/parse
racket/syntax racket/syntax
racket/generic racket/generic
racket/format racket/format
racket/list racket/list
racket/match
(prefix-in remix: remix/stx0) (prefix-in remix: remix/stx0)
remix/stx/singleton-struct0 remix/stx/singleton-struct0
(for-syntax racket/base (for-syntax racket/base
@ -185,7 +187,11 @@
(begin-for-syntax (begin-for-syntax
;; XXX fill this in for parents, etc ;; XXX fill this in for parents, etc
(define-generics layout) (define-generics layout
(layout-planner layout)
;; xxx the accessors seem to not be around anyways, so instead,
;; this should just be a mapping produced by the planner.
(layout-field->acc layout))
(begin-for-syntax (begin-for-syntax
(define-generics layout-planner (define-generics layout-planner
(layout-planner-mutable? layout-planner))) (layout-planner-mutable? layout-planner)))
@ -208,36 +214,62 @@
(syntax-parse stx (syntax-parse stx
#:literals (remix:#%brackets) #:literals (remix:#%brackets)
[(def (remix:#%brackets me:id name:id) [(def (remix:#%brackets me:id name:id)
(~optional (~and (~seq #:parent (~var parent (static layout? "layout")))
(~bind [parent-va (attribute parent.value)]))
#:defaults ([parent-va #f]))
f:id ...) f:id ...)
;; xxx check for duplicates in f (define parent-v (attribute parent-va))
(define the-planner
(or (and parent-v (layout-planner parent-v))
;; xxx allow the default planner to be customized and
;; ensure it is equal to the parent's
#'layout-immutable))
(define parent-f->acc
(or (and parent-v (layout-field->acc parent-v))
(hasheq)))
(define f->acc
(for/fold ([base parent-f->acc])
([the-f (in-list (syntax->datum #'(f ...)))]
[the-idx (in-naturals (hash-count parent-f->acc))])
(when (hash-has-key? base the-f)
(raise-syntax-error 'layout
(format "duplicate field ~a in layout"
the-f)
stx
the-f))
(define the-name-f (format-id #f "~a-~a" #'name the-f))
(hash-set base the-f (cons the-name-f the-idx))))
(with-syntax* ([name-alloc (format-id #f "~a-alloc" #'name)] (with-syntax* ([name-alloc (format-id #f "~a-alloc" #'name)]
[name-set (format-id #f "~a-set" #'name)] [name-set (format-id #f "~a-set" #'name)]
[(f-idx ...) [((all-f all-name-f all-f-idx) ...)
(for/list ([i (in-naturals)] (for/list ([(the-f v) (in-hash f->acc)])
[f (in-list (syntax->list #'(f ...)))]) (match-define (cons the-name-f the-f-idx) v)
i)] (list the-f the-name-f the-f-idx))]
[(name-f ...) [stx-the-planner the-planner]
(for/list ([f (in-list (syntax->list #'(f ...)))]) [stx-f->acc f->acc])
(format-id #f "~a-~a" #'name f))])
(syntax/loc stx (syntax/loc stx
(begin (begin
(begin-for-syntax (begin-for-syntax
(define f->idx*acc (define f->acc stx-f->acc)
;; xxx base on parent's
(make-immutable-hasheq
(list (cons 'f (cons f-idx #'name-f))
...)))
(define available-fields (define available-fields
(sort (hash-keys f->idx*acc) (sort (hash-keys f->acc)
string<=? string<=?
#:key symbol->string)) #:key symbol->string))
(define ordered-fields
(sort (hash-keys f->acc)
<=
#:key (λ (x)
(cdr (hash-ref f->acc x)))))
(define-syntax-class name-arg (define-syntax-class name-arg
#:attributes (lhs rhs) #:attributes (lhs rhs)
#:literals (remix:#%brackets) #:literals (remix:#%brackets)
(pattern (remix:#%brackets lhs:id rhs:expr) (pattern (remix:#%brackets lhs:id rhs:expr)
#:do [(define lhs-v (syntax->datum #'lhs))]
#:fail-unless #:fail-unless
(hash-has-key? f->idx*acc (syntax->datum #'lhs)) (hash-has-key? f->acc lhs-v)
(format "valid field: ~a" available-fields))) (format "invalid field given: ~a, valid fields are: ~a"
lhs-v
available-fields)))
(define-syntax-class name-args (define-syntax-class name-args
#:attributes (f->rhs) #:attributes (f->rhs)
(pattern (a:name-arg (... ...)) (pattern (a:name-arg (... ...))
@ -254,7 +286,7 @@
(syntax-parse stx (syntax-parse stx
[(_ . args:name-args) [(_ . args:name-args)
(with-syntax ([(f-val (... ...)) (with-syntax ([(f-val (... ...))
(for/list ([this-f (in-list '(f ...))]) (for/list ([this-f (in-list ordered-fields)])
(hash-ref (attribute args.f->rhs) (hash-ref (attribute args.f->rhs)
this-f this-f
(λ () (λ ()
@ -271,8 +303,8 @@
[(_ base:expr . args:name-args) [(_ base:expr . args:name-args)
(with-syntax* ([base-id (generate-temporary #'base)] (with-syntax* ([base-id (generate-temporary #'base)]
[(f-val (... ...)) [(f-val (... ...))
(for/list ([this-f (in-list '(f ...))] (for/list ([this-f (in-list ordered-fields)])
[this-name-f (in-list '(name-f ...))]) (define this-name-f (car (hash-ref f->acc this-f)))
(hash-ref (attribute args.f->rhs) (hash-ref (attribute args.f->rhs)
this-f this-f
(λ () (λ ()
@ -284,7 +316,7 @@
(vector-immutable f-val (... ...)))))])) (vector-immutable f-val (... ...)))))]))
(begin-encourage-inline (begin-encourage-inline
;; xxx push this in representation planner ;; xxx push this in representation planner
(define (name-f v) (unsafe-vector*-ref v f-idx)) (define (all-name-f v) (unsafe-vector*-ref v all-f-idx))
...) ...)
(define-syntax name (define-syntax name
(phase1:static-interface (phase1:static-interface
@ -292,11 +324,14 @@
(remix:#%brackets #:set name-set) (remix:#%brackets #:set name-set)
(remix:#%brackets #:= name-set) (remix:#%brackets #:= name-set)
;; xxx add set! if planner says so ;; xxx add set! if planner says so
(remix:#%brackets f name-f) (remix:#%brackets all-f all-name-f)
... ...
#:extensions #:extensions
#:methods gen:layout #:methods gen:layout
[])))))]))])) [(define (layout-planner _)
#'stx-the-planner)
(define (layout-field->acc _)
f->acc)])))))]))]))
(provide (rename-out [phase0:layout layout]) (provide (rename-out [phase0:layout layout])
(for-meta 2 (for-meta 2

17
remix/tests/simple.rkt
View File

@ -347,16 +347,27 @@
{p3.x ≡ 8} {p3.x ≡ 8}
{p3.y ≡ 7}) {p3.y ≡ 7})
;; XXX This is where I am
;; A layout can have a parent, which provides the guarantee that the ;; A layout can have a parent, which provides the guarantee that the
;; parent's functions will work on the child---meaning that whatever ;; parent's functions will work on the child---meaning that whatever
;; the layout ends up being (and you can't decide that), the two will ;; the layout ends up being (and you can't decide that), the two will
;; overlap in this specific way. A layout has one or zero parents. ;; overlap in this specific way. A layout has one or zero parents.
#;
(def [layout quat] (def [layout quat]
#:parent posn #:parent posn
z) z)
(module+ test
(def [quat q1] (quat.#:alloc [x 1] [y 2] [z 3]))
{q1.x ≡ 1}
{q1.y ≡ 2}
{q1.z ≡ 3}
(def [posn qp1] q1)
{qp1.x ≡ 1}
{qp1.y ≡ 2}
(def [quat qpq1] qp1)
{qpq1.x ≡ 1}
{qpq1.y ≡ 2}
{qpq1.z ≡ 3})
;; XXX This is where I am
;; A layout's fields may be specified as other layouts. When the first ;; A layout's fields may be specified as other layouts. When the first
;; field is a layout, this is not necessarily the same thing as a ;; field is a layout, this is not necessarily the same thing as a