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

fields with layouts/def transformers

Browse Source
This commit is contained in:
Jay McCarthy 2015-12-02 19:06:32 -05:00
parent 39041fae09
commit 79dbc986a3
2 changed files with 74 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
remix/data0.rkt
View File

@ -1,20 +1,19 @@
#lang racket/base #lang racket/base
(require (for-syntax (require (for-syntax racket/base
racket/base syntax/quote
syntax/quote syntax/parse
syntax/parse racket/syntax
racket/syntax racket/generic
racket/generic racket/format
racket/format racket/list
racket/list racket/match
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 racket/syntax
racket/syntax syntax/parse
syntax/parse racket/generic
racket/generic (prefix-in remix: remix/stx0)))
(prefix-in remix: remix/stx0)))
racket/unsafe/ops racket/unsafe/ops
racket/performance-hint racket/performance-hint
(prefix-in remix: remix/stx0)) (prefix-in remix: remix/stx0))
@ -53,7 +52,13 @@
(syntax->list #'(lhs ...))))]) (syntax->list #'(lhs ...))))])
(format-id #f "~a-~a-for-def" #'int-name (format-id #f "~a-~a-for-def" #'int-name
(if (keyword? lhs) (keyword->string lhs) (if (keyword? lhs) (keyword->string lhs)
lhs)))]) lhs)))]
[(full-def-rhs ...)
(for/list ([def-rhs (in-list (syntax->list #'(def-rhs ...)))]
[rhs-dt (in-list (syntax->list #'(rhs-dt ...)))])
(if (syntax-e rhs-dt)
(list def-rhs '#:is rhs-dt)
(list def-rhs)))])
(syntax/loc stx (syntax/loc stx
(let () (let ()
(define int-id->orig (define int-id->orig
@ -138,7 +143,7 @@
... ...
(remix:def (remix:#%brackets remix:stx i) (remix:def (remix:#%brackets remix:stx i)
(phase1:static-interface (phase1:static-interface
(remix:#%brackets lhs def-rhs) (remix:#%brackets lhs . full-def-rhs)
... ...
#:extensions #:extensions
;; NB I don't pass on other ;; NB I don't pass on other
@ -148,13 +153,13 @@
;; they might be. ;; they might be.
#:property prop:procedure #:property prop:procedure
(λ (_ stx) (λ (_ stx)
(syntax-parse stx (syntax-parse stx
[_:id [_:id
(syntax/loc stx (syntax/loc stx
real-i)] real-i)]
[(_ . blah:expr) [(_ . blah:expr)
(syntax/loc stx (syntax/loc stx
(real-i . blah))])))))))]))] (real-i . blah))])))))))]))]
extension ...))))]))) extension ...))))])))
(define-syntax (define-phase0-def->phase1-macro stx) (define-syntax (define-phase0-def->phase1-macro stx)
@ -202,7 +207,15 @@
(define-syntax layout-mutable (define-syntax layout-mutable
(singleton-struct (singleton-struct
#:methods gen:layout-planner #:methods gen:layout-planner
[(define (layout-planner-mutable? lp) #t)]))) [(define (layout-planner-mutable? lp) #t)]))
(define-syntax-class field
#:attributes (name dt)
#:literals (remix:#%brackets)
(pattern name:id
#:attr dt #f)
(pattern (remix:#%brackets dt name:id)
#:declare dt (static remix:def-transformer? "def transformer"))))
(define-syntax phase0:layout (define-syntax phase0:layout
(singleton-struct (singleton-struct
@ -217,7 +230,7 @@
(~optional (~and (~seq #:parent (~var parent (static layout? "layout"))) (~optional (~and (~seq #:parent (~var parent (static layout? "layout")))
(~bind [parent-va (attribute parent.value)])) (~bind [parent-va (attribute parent.value)]))
#:defaults ([parent-va #f])) #:defaults ([parent-va #f]))
f:id ...) F:field ...)
(define parent-v (attribute parent-va)) (define parent-v (attribute parent-va))
(define the-planner (define the-planner
(or (and parent-v (layout-planner parent-v)) (or (and parent-v (layout-planner parent-v))
@ -229,7 +242,8 @@
(hasheq))) (hasheq)))
(define f->acc (define f->acc
(for/fold ([base parent-f->acc]) (for/fold ([base parent-f->acc])
([the-f (in-list (syntax->datum #'(f ...)))] ([the-f (in-list (syntax->datum #'(F.name ...)))]
[the-dt (in-list (attribute F.dt))]
[the-idx (in-naturals (hash-count parent-f->acc))]) [the-idx (in-naturals (hash-count parent-f->acc))])
(when (hash-has-key? base the-f) (when (hash-has-key? base the-f)
(raise-syntax-error 'layout (raise-syntax-error 'layout
@ -238,13 +252,17 @@
stx stx
the-f)) the-f))
(define the-name-f (format-id #f "~a-~a" #'name 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)))) (hash-set base the-f (vector the-name-f the-dt 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)]
[((all-f all-name-f all-f-idx) ...) [((all-f all-name-f all-f-si-rhs all-f-idx) ...)
(for/list ([(the-f v) (in-hash f->acc)]) (for/list ([(the-f v) (in-hash f->acc)])
(match-define (cons the-name-f the-f-idx) v) (match-define (vector the-name-f the-dt the-f-idx) v)
(list the-f the-name-f the-f-idx))] (list the-f the-name-f
(if the-dt
(list the-name-f '#:is the-dt)
(list the-name-f))
the-f-idx))]
[stx-the-planner the-planner] [stx-the-planner the-planner]
[stx-f->acc f->acc]) [stx-f->acc f->acc])
(syntax/loc stx (syntax/loc stx
@ -259,7 +277,7 @@
(sort (hash-keys f->acc) (sort (hash-keys f->acc)
<= <=
#:key (λ (x) #:key (λ (x)
(cdr (hash-ref f->acc x))))) (vector-ref (hash-ref f->acc x) 2))))
(define-syntax-class name-arg (define-syntax-class name-arg
#:attributes (lhs rhs) #:attributes (lhs rhs)
#:literals (remix:#%brackets) #:literals (remix:#%brackets)
@ -304,7 +322,10 @@
(with-syntax* ([base-id (generate-temporary #'base)] (with-syntax* ([base-id (generate-temporary #'base)]
[(f-val (... ...)) [(f-val (... ...))
(for/list ([this-f (in-list ordered-fields)]) (for/list ([this-f (in-list ordered-fields)])
(define this-name-f (car (hash-ref f->acc this-f))) (define this-name-f
(vector-ref
(hash-ref f->acc this-f)
0))
(hash-ref (attribute args.f->rhs) (hash-ref (attribute args.f->rhs)
this-f this-f
(λ () (λ ()
@ -321,10 +342,11 @@
(define-syntax name (define-syntax name
(phase1:static-interface (phase1:static-interface
(remix:#%brackets #:alloc name-alloc) (remix:#%brackets #:alloc name-alloc)
;; xxx perhaps allow planner to not have this
(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 all-f all-name-f) (remix:#%brackets all-f . all-f-si-rhs)
... ...
#:extensions #:extensions
#:methods gen:layout #:methods gen:layout
@ -345,4 +367,3 @@
;; xxx (dynamic-)interface ;; xxx (dynamic-)interface
;; xxx data ;; xxx data

22
remix/tests/simple.rkt
View File

@ -359,30 +359,42 @@
{q1.x ≡ 1} {q1.x ≡ 1}
{q1.y ≡ 2} {q1.y ≡ 2}
{q1.z ≡ 3} {q1.z ≡ 3}
;; We can consider to be posn (imaging calling some function that
;; expects one) and it just works
(def [posn qp1] q1) (def [posn qp1] q1)
{qp1.x ≡ 1} {qp1.x ≡ 1}
{qp1.y ≡ 2} {qp1.y ≡ 2}
;; However, that casting is computation-less, so it can be cast back
;; and we can get all the fields. However, if we changed it, it
;; wouldn't have stayed a quat.
(def [quat qpq1] qp1) (def [quat qpq1] qp1)
{qpq1.x ≡ 1} {qpq1.x ≡ 1}
{qpq1.y ≡ 2} {qpq1.y ≡ 2}
{qpq1.z ≡ 3}) {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
;; parent (like C structs) but it may be. (No matter what, you'd never ;; parent (like C structs) but it may be. (No matter what, you'd never
;; be able to tell, since layout doesn't make representation promises ;; be able to tell, since layout doesn't make representation promises
;; as a rule.) ;; as a rule.)
#;
(def [layout circle] (def [layout circle]
[posn c] r) [posn c] r)
(module+ test
(def [circle c1] (circle.#:alloc [c p1] [r 8]))
{c1.c.x ≡ 5}
{c1.c.y ≡ 7}
{c1.r ≡ 8})
;; A layout's fields can _actually_ just be any def transformer, and ;; A layout's fields can _actually_ just be any def transformer, and
;; thus could be static interfaces ;; thus could be static interfaces
#;
(def [layout weird] (def [layout weird]
[example1^ e]) [example^ e])
(module+ test
(def [weird w1] (weird.#:alloc [e 1]))
{(w1.e.f 2) ≡ 1}
{(w1.e.g 2) ≡ 2})
;; XXX This is where I am
;; Now, the big reveal, layout has an extensible representation ;; Now, the big reveal, layout has an extensible representation
;; planner system. At the moment, the only representations are ;; planner system. At the moment, the only representations are