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
(require (for-syntax
racket/base
syntax/quote
syntax/parse
racket/syntax
racket/generic
racket/format
racket/list
racket/match
(prefix-in remix: remix/stx0)
remix/stx/singleton-struct0
(for-syntax racket/base
@ -185,7 +187,11 @@
(begin-for-syntax
;; 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
(define-generics layout-planner
(layout-planner-mutable? layout-planner)))
@ -208,36 +214,62 @@
(syntax-parse stx
#:literals (remix:#%brackets)
[(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 ...)
;; 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)]
[name-set (format-id #f "~a-set" #'name)]
[(f-idx ...)
(for/list ([i (in-naturals)]
[f (in-list (syntax->list #'(f ...)))])
i)]
[(name-f ...)
(for/list ([f (in-list (syntax->list #'(f ...)))])
(format-id #f "~a-~a" #'name f))])
[((all-f all-name-f all-f-idx) ...)
(for/list ([(the-f v) (in-hash f->acc)])
(match-define (cons the-name-f the-f-idx) v)
(list the-f the-name-f the-f-idx))]
[stx-the-planner the-planner]
[stx-f->acc f->acc])
(syntax/loc stx
(begin
(begin-for-syntax
(define f->idx*acc
;; xxx base on parent's
(make-immutable-hasheq
(list (cons 'f (cons f-idx #'name-f))
...)))
(define f->acc stx-f->acc)
(define available-fields
(sort (hash-keys f->idx*acc)
(sort (hash-keys f->acc)
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
#:attributes (lhs rhs)
#:literals (remix:#%brackets)
(pattern (remix:#%brackets lhs:id rhs:expr)
#:do [(define lhs-v (syntax->datum #'lhs))]
#:fail-unless
(hash-has-key? f->idx*acc (syntax->datum #'lhs))
(format "valid field: ~a" available-fields)))
(hash-has-key? f->acc lhs-v)
(format "invalid field given: ~a, valid fields are: ~a"
lhs-v
available-fields)))
(define-syntax-class name-args
#:attributes (f->rhs)
(pattern (a:name-arg (... ...))
@ -254,7 +286,7 @@
(syntax-parse stx
[(_ . args:name-args)
(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)
this-f
(λ ()
@ -271,8 +303,8 @@
[(_ base:expr . args:name-args)
(with-syntax* ([base-id (generate-temporary #'base)]
[(f-val (... ...))
(for/list ([this-f (in-list '(f ...))]
[this-name-f (in-list '(name-f ...))])
(for/list ([this-f (in-list ordered-fields)])
(define this-name-f (car (hash-ref f->acc this-f)))
(hash-ref (attribute args.f->rhs)
this-f
(λ ()
@ -284,7 +316,7 @@
(vector-immutable f-val (... ...)))))]))
(begin-encourage-inline
;; 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
(phase1:static-interface
@ -292,11 +324,14 @@
(remix:#%brackets #:set name-set)
(remix:#%brackets #:= name-set)
;; xxx add set! if planner says so
(remix:#%brackets f name-f)
(remix:#%brackets all-f all-name-f)
...
#:extensions
#:methods gen:layout
[])))))]))]))
[(define (layout-planner _)
#'stx-the-planner)
(define (layout-field->acc _)
f->acc)])))))]))]))
(provide (rename-out [phase0:layout layout])
(for-meta 2

17
remix/tests/simple.rkt
View File

@ -347,16 +347,27 @@
{p3.x ≡ 8}
{p3.y ≡ 7})
;; XXX This is where I am
;; A layout can have a parent, which provides the guarantee that the
;; 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
;; overlap in this specific way. A layout has one or zero parents.
#;
(def [layout quat]
#:parent posn
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
;; field is a layout, this is not necessarily the same thing as a