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

The get macro now works well, but needs a patch in typed/racket to fix a bug when providing promises which need to be wrapped in a contract.

Browse Source
This commit is contained in:
Georges Dupéron 2015-12-17 14:14:42 +01:00
parent 6e5bc55402
commit 2c0dfe7350
8 changed files with 261 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
graph/graph/__DEBUG_graph__.rkt
View File

@ -1,4 +1,4 @@
#lang debug typed/racket
#lang typed/racket
#|
(require "structure.lp2.rkt")
@ -19,15 +19,21 @@
|#
(require (submod "graph3.lp2.rkt" test))
(require "graph3.lp2.rkt")
(require "graph4.lp2.rkt")
(require "structure.lp2.rkt")
(require "variant.lp2.rkt")
(require "../lib/low.rkt")
(require "../type-expander/type-expander.lp2.rkt")
;(structure-get people)
(structure-get (cadr g) people)
(structure-get (cadr (force g)) people)
(get g people)
(get g streets cadr houses car owner name)
((λget people) g)
((λget owner name) (get g streets cadr houses car))
;;((λget streets cadr houses car owner name) g)
;;(map (λget houses car owner name) (get g streets))
#|
(define #:∀ (A) (map-force [l : (Listof (Promise A))])

27
graph/graph/__DEBUG_structure-supertype__.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang typed/racket
(require "../type-expander/type-expander.lp2.rkt")
(define-type-expander (CPairof stx)
(syntax-case stx ()
[(_ a) #'(curry Pairof a)]
[(_ a b) #'(Pairof a b)]))
(ann (ann '(1 . "b") (CPairof Number String))
(Pairof Number String))
(ann (ann '(1 . "c") ((CPairof Number) String))
(Pairof Number String))
(require "structure.lp2.rkt")
(require "../type-expander/type-expander.lp2.rkt")
(define ab (structure [f-a 1] [f-b "b"]))
(define abc (structure [f-a 1] [f-b "b"] [f-c 'c]))
(define f
(λ ([x : (structure-supertype [f-a Number] [f-b String])])
x))
(f ab)
(f abc)

14
graph/graph/graph3.lp2.rkt
View File

@ -112,7 +112,9 @@ the root arguments as parameters.
@chunk[<use-example>
(define-graph make-g <example-variants>)
(define g (make-g <example-root>))]
#;(define g (make-g <example-root>))
(define g1 (make-g <example-root>))
(define g g1)]
@subsection{More details on the semantics}
@ -591,14 +593,14 @@ are replaced by tagged indices:
(begin <define-with-promises>) …
(begin <define-incomplete>) …
(begin <define-mapping-function>) …
(: name (→ root-param-type … root/with-promises-type))
(: name (→ root-param-type … (Promise root/with-promises-type)))
(define (name root-param …)
(match-let ([(list node/database …) <fold-queues>])
(begin <define-with-indices→with-promises>) …
;(list node/with-indices→with-promises …)
(root/with-indices→with-promises
(vector-ref root/database 0))))))#|)|#)]
(let ([root/with-promises (root/with-indices→with-promises
(vector-ref root/database 0))])
(delay root/with-promises)))))))]
@section{Conclusion}

67
graph/graph/graph4.lp2.rkt
View File

@ -14,7 +14,7 @@ is correctly taken into account. Note that @tc[car] would still work, because we
also match identifiers with the @tc[c…r] syntax, as a fallback or for chains of
more than 4 letters.
@CHUNK[<c*r-syntax-class>
@CHUNK[<c…r-syntax-class>
(define-syntax-class c…r
;(pattern (~literal car) #:with (expanded …) #'(car))
;(pattern (~literal cdr) #:with (expanded …) #'(cdr))
@ -85,12 +85,14 @@ otherwise throw an error:
@chunk[<get-tagged>
[((make-predicate (List Symbol Any)) v-cache)
(get (structure-get (cadr v-cache) field) other-fields …)]]
@chunk[<get-promise>
[(promise? v-cache)
(let ([f-cache (force v-cache)])
(if ((make-predicate (List Symbol Any)) f-cache)
(get (structure-get (cadr f-cache) field) other-fields …)
(get (structure-get f-cache field) other-fields …)))]]
@chunk[<get-plain-struct>
[else
(get (structure-get v-cache field) other-fields …)]]
@ -98,6 +100,55 @@ otherwise throw an error:
@chunk[<test-get>
(check-equal? 'TODO 'TODO)]
@section{@racket[λget]}
@chunk[<λget>
(define-syntax (λget stx)
(syntax-parse stx
;[(_ v:expr (~and c?r (~or (~lit car) (~lit cdr))) other-fields …)
; #'(get (c?r v) other-fields …)]
;[(_ v:expr c…r:c…r other-fields …)
; #`(get v #,@(reverse (syntax->list #'(c…r.expanded …)))
; other-fields …)]
[(_ field:id …)
#'(ann (λ (v) (get v field …))
(∀ (T) (→ (λget-type-helper T field …) T)))]))]
The type for the function generated by @tc[λget] mirrors the cases from
@tc[get].
@; TODO: To avoid the n⁴ code size complexity (with n being the number of fields
@; in the expression (λget f₁ … fₙ), maybe we should always wrap structures in a
@; list with a dummy symbol as the first element, and wrap that in a promise
@; that just returns the value. That way, we'll always fall in the
@; @tc[(Promise (List <r>))] case. Using a named type of the form
@; @tc[(define-type (maybe-wrapped S) (U S (List Symbol S)
@; (Promise (U S (List Symbol S)))))]
@; won't work, because TR inlines these, unless they are recursive.
@; We could otherwise try to make sure that the user never sees a Promise, and
@; always force it when we return one (and node types would be
@; @tc[(U with-fields=promises with-fields=with-promises)
@; Or we could put in a fake piece of recursion to prevent TR from expanding the
@; type, but that behaviour could change in the future:
@; @tc[(define-type (maybe-wrapped S) (U S
@; (List Symbol S)
@; (Promise (U S (List Symbol S)))
@; (→ (maybe-wrapped S) unforgeable))))]
@chunk[<λget-type-helper>
(define-type-expander (λget-type-helper stx)
(syntax-parse stx
[(_ T:expr)
#'T]
[(_ T:expr field:id other-fields:id …)
#;#'(U <r>
(List Symbol <r>)
(Promise (U <r> (List Symbol <r>))))
#'(Promise (List Symbol <r>))]))]
@chunk[<r>
(structure-supertype [field (λget-type-helper T other-fields …)])]
@section{Conclusion}
@chunk[<module-main>
@ -108,19 +159,23 @@ otherwise throw an error:
"../lib/low.rkt"
"structure.lp2.rkt"
"variant.lp2.rkt"
"graph3.lp2.rkt")
(provide get)
"graph3.lp2.rkt"
"../type-expander/type-expander.lp2.rkt")
(provide get
λget)
(begin-for-syntax
<c*r-syntax-class>)
<c…r-syntax-class>)
<get>)]
<get>
<λget-type-helper>
<λget>)]
@chunk[<module-test>
(module* test typed/racket
(require (submod "..")
typed/rackunit)
<test-get>
(require (submod ".." doc)))]

14
graph/graph/remember.rkt
View File

@ -55,3 +55,17 @@
(structure houses/with-promises-type sname/with-promises-type)
(structure houses sname)
(structure houses sname)
(structure f-a f-b)
(structure f-a f-b f-c)
(structure people)
(structure streets)
(structure location)
(structure streets)
(structure streets)
(structure x)
(structure x)
(structure x)
(structure sname)
(structure sname)
(structure sname)
(structure st)

37
graph/graph/structure.lp2.rkt
View File

@ -26,7 +26,7 @@ types, it wouldn't be clear what fields the remaining type parameters affect).
(define-syntax-class field-descriptor
(pattern
(~or field:id
[field:id (~maybe (~lit :) type:expr) (~maybe value:expr)]))))}
[field:id (~maybe :colon type:expr) (~maybe value:expr)]))))}
A call to @tc[(structure)] with no field, is ambiguous: it could return a
constructor function, or an instance. We added two optional keywords,
@ -41,10 +41,10 @@ handle the empty structure as a special case.
(~seq #:constructor (~parse (field …) #'()))
(~seq (~maybe #:constructor ~!)
(~or (~seq (~or-bug [field:id] field:id) …+)
(~seq [field:id (~and C (~lit :)) type:expr] …+)))
(~seq [field:id (~and C :colon) type:expr] …+)))
(~seq (~maybe #:instance ~!)
(~or (~seq [field:id value:expr] …+)
(~seq [field:id (~and C (~lit :)) type:expr
(~seq [field:id (~and C :colon) type:expr
value:expr] …+))))))]
@chunk[<structure>
@ -236,7 +236,7 @@ one low-level @tc[struct] is generated for them.
(for/list ([s (remove-duplicates (map (λ (s) (sort s symbol<?))
(get-remembered 'structure)))]
[i (in-naturals)])
`(,(string->symbol (format "struct-~a" i)) . ,s)))]
`(,(string->symbol (~a `(structure ,(~a "#|" i "|#") . ,s))) . ,s)))]
We will also need utility functions to sort the fields when querying this
associative list.
@ -310,6 +310,7 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
(stx-map sort-fields #'((all-field …) …)))
(define/with-syntax ([[sorted-field sorted-pat …] …] …)
(stx-map (curry stx-map
;; TODO: add (_ _ …) for the not-matched fields.
(λ (x) (multiassoc-syntax x #'([field pat …] …))))
#'((sorted-field1 …) …)))
#'(or (name (and sorted-field sorted-pat …) …) …))]
@ -317,10 +318,30 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
@chunk[<structure-supertype>
(define-multi-id structure-supertype
#:type-expander
(λ/syntax-parse (_ field:id …)
#`(U #,@(map cdr (fields→supertypes #'(field …)))))
(λ/syntax-parse (_ [field:id type:expr] …)
(define/with-syntax ([(all-field …) . _] …)
(fields→supertypes #'(field …)))
(template
(U (structure
[all-field : (tmpl-cdr-assoc-syntax #:default Any
all-field [field . type] …)]
…)
…)))
#:match-expander <structure-supertype-match-expander>)]
@chunk[<structure-supertype*>
(define-multi-id structure-supertype*
#:type-expander
(λ (stx)
(syntax-parse stx
[(_ T:expr)
#`T]
[(_ T:expr field:id other-fields:id …)
#`(structure-supertype
[field (structure-supertype* T other-fields …)])]))
;#:match-expander <structure-supertype-match-expander> ; TODO
)]
@chunk[<fields→supertypes>
(define-for-syntax (fields→supertypes stx-fields)
(with-syntax ([(field …) stx-fields])
@ -583,7 +604,8 @@ chances that we could write a definition for that identifier.
structure-get
λstructure-get
structure
structure-supertype)
structure-supertype
structure-supertype*)
(begin-for-syntax
(provide structure-args-stx-class))
@ -607,6 +629,7 @@ chances that we could write a definition for that identifier.
<syntax-class-for-match>
<structure-supertype>
<structure-supertype*>
<match-expander>
<type-expander>

20
graph/lib/low/multiassoc-syntax.rkt
View File

@ -8,16 +8,28 @@
cdr-assoc-syntax
tmpl-cdr-assoc-syntax)
(require "../low.rkt") ;; For the identifier "…"
;; TODO: cdr-stx-assoc is already defined in lib/low.rkt
(define (multiassoc-syntax query alist)
(map stx-cdr
(filter (λ (xy) (free-identifier=? query (stx-car xy)))
(syntax->list alist))))
(define (cdr-assoc-syntax query alist)
(stx-cdr (findf (λ (xy) (free-identifier=? query (stx-car xy)))
(syntax->list alist))))
(stx-cdr (assoc-syntax query alist)))
(define (assoc-syntax query alist)
(findf (λ (xy) (free-identifier=? query (stx-car xy)))
(syntax->list alist)))
(define-template-metafunction (tmpl-cdr-assoc-syntax stx)
(syntax-parse stx
[(_ query [k . v] …)
(cdr-assoc-syntax #'query #'([k . v] …))]))
[(_ (~optional (~seq #:default default)) query [k . v] …)
(if (attribute default)
(let ([r (assoc-syntax #'query #'([k . v] …))])
(if r
(stx-cdr r)
#'default))
(cdr-assoc-syntax #'query #'([k . v] …)))]))

158
graph/type-expander/type-expander.lp2.rkt
View File

@ -30,8 +30,8 @@ Match expanders are identified by the @tc[prop:type-expander]
get-prop:type-expander-value)
(make-struct-type-property 'type-expander prop-guard))]
The prop:type-expander property should either be the index of a field which will
contain the expander procedure, or directly an expander procedure.
The @tc[prop:type-expander] property should either be the index of a field which
will contain the expander procedure, or directly an expander procedure.
@chunk[<prop-guard>
(define (prop-guard val struct-type-info-list)
@ -101,12 +101,25 @@ else.
(define-syntax-class type-expander
(pattern (~var expander
(static has-prop:type-expander? "a type expander"))))
(define-syntax-class type-expander-nested-application
#:attributes (expanded-once)
(pattern (~and expander-call-stx (:type-expander . args))
#:with expanded-once
(apply-type-expander #'expander #'expander-call-stx))
(pattern (nested-application:type-expander-nested-application
. args) ;; TODO: test
#:with expanded-once
#'(nested-application.expanded-once . args)))
(define-syntax-class fa (pattern (~or (~literal ∀) (~literal All))))
(syntax-parse stx
[:type-expander
(expand-type (apply-type-expander #'expander #'expander))]
[(~and expander-call-stx (:type-expander . args))
(expand-type (apply-type-expander #'expander #'expander-call-stx))]
[:type-expander-nested-application
(expand-type #'expanded-once)]
;; TODO: find a more elegant way to write anonymous type expanders
[(((~literal curry) T Arg1 …) . Args2)
(expand-type #'(T Arg1 … . Args2))]
;; TODO: handle the pattern (∀ (TVar ... ooo) T)
[(∀:fa (TVar ...) T)
#`(∀ (TVar ...) #,(expand-type (bind-type-vars #'(TVar ...) #'T)))]
@ -117,8 +130,6 @@ else.
[((~literal syntax) T) (expand-quasiquote 'syntax 1 #'T)]
[((~literal quasisyntax) T) (expand-quasiquote 'quasisyntax 1 #'T)]
[((~literal Struct) T)
(display #'(Struct T))
(displayln #`(Struct #,(expand-type #'(T))))
#`(Struct #,(expand-type #'T))]
[(T TArg ...)
#`(T #,@(stx-map expand-type #'(TArg ...)))]
@ -161,6 +172,28 @@ identifier.
(test-expander (∀ (A) (→ A (id (double (id A)))))
(∀ (A) (→ A (Pairof A A))))]
Curry expander arguments:
@CHUNK[<test-expand-type>
(define-type-expander (CPairof stx)
(syntax-case stx ()
[(_ a) #'(curry Pairof a)]
[(_ a b) #'(Pairof a b)]))
(test-expander (CPairof Number String)
(Pairof Number String))
(test-expander ((CPairof Number) String)
(Pairof Number String))
(check-equal?: (ann (ann '(1 . "b") (CPairof Number String))
(Pairof Number String))
'(1 . "b"))
(check-equal?: (ann (ann '(1 . "c") ((CPairof Number) String))
(Pairof Number String))
'(1 . "c"))]
Shadowing and @tc[∀] variables:
@CHUNK[<test-expand-type>
@ -449,10 +482,10 @@ them.
: `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d)
'(2 "abc" #,(x . z) #(1 "b" x) d))
(check-equal?: (ann d0 (List 2
"abc"
(List 'unsyntax (Pairof (U 'x 'y) (U 'y 'z)))
(Vector 1 "b" 'x) 'd))
'(2 "abc" (unsyntax (x . z)) #(1 "b" x) d))
"abc"
(List 'unsyntax (Pairof (U 'x 'y) (U 'y 'z)))
(Vector 1 "b" 'x) 'd))
'(2 "abc" (unsyntax (x . z)) #(1 "b" x) d))
(: d1 (→ Number (→ Number Number)))
(define ((d1 [x : Number]) [y : Number]) : Number (+ x y))
@ -480,13 +513,13 @@ them.
@CHUNK[<test-lambda>
(check-equal?: ((ann (lambda ([x : Number]) : Number (* x 2))
(→ Number Number))
3)
6)
(→ Number Number))
3)
6)
(check-equal?: ((ann (λ ([x : Number]) : Number (* x 2))
(→ Number Number))
3)
6)
(→ Number Number))
3)
6)
(check-equal?: ((λ x x) 1 2 3) '(1 2 3))
(check-equal?: ((λ #:∀ (A) [x : A ...*] : (Listof A) x) 1 2 3) '(1 2 3))]
@ -609,7 +642,7 @@ them.
(check-equal?: (cdr ((se1 123) 'b)) 'b)
(check-not-exn (λ () (ann (car ((se1 123) 'b)) se1)))
(check-true (se1? (car ((se1 123) 'b))))
(check (λ (a b) (not (equal? a b))) (se2 2 3) (se2 2 3))
(check-equal?: (se2-x (se2 2 3)) 2)
(check-equal?: (se2-y (se2 2 3)) 3)
@ -618,7 +651,7 @@ them.
(check-equal?: (cdr ((se2 2 3) 'c)) 'c)
(check-not-exn (λ () (ann (car ((se2 2 3) 'c)) se2)))
(check-true (se2? (car ((se2 2 3) 'c))))
(check (λ (a b) (not (equal? a b))) (se3 4 5 "f") (se3 4 5 "f"))
(check-equal?: (se2-x (se3 4 5 "f")) 4)
(check-equal?: (se2-y (se3 4 5 "f")) 5)
@ -626,10 +659,10 @@ them.
(check-equal?: (se2-x (car ((se3 4 5 "f") 'd 'e))) 4)
(check-equal?: (se2-y (car ((se3 4 5 "f") 'd 'e))) 5)
(check-equal?: (let ([ret : Any (car ((se3 4 5 "f") 'd 'e))])
(if (se3? ret)
(se3-z ret)
"wrong type!"))
"f")
(if (se3? ret)
(se3-z ret)
"wrong type!"))
"f")
(check-equal?: (cadr ((se3 4 5 "f") 'd 'e)) 'd)
(check-equal?: (caddr ((se3 4 5 "f") 'd 'e)) 'e)
(check-equal?: ((caddr ((se4 4 5 "f") 'd (λ ([x : Number]) (* x 2)))) 12)
@ -651,9 +684,9 @@ them.
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(check-equal?: (ann (ann '(1 2 3)
(Repeat Number 3))
(List Number Number Number))
'(1 2 3)))]
(Repeat Number 3))
(List Number Number Number))
'(1 2 3)))]
@subsection{@racket[inst]}
@ -676,13 +709,13 @@ them.
(define (f x y) (list (car x) (car y) (cdr x) (cdr y)))
(check-equal?: ((inst f
(Repeat Number 3)
(Repeat String 2)
(Repeat 'x 1)
(Repeat undefined-type 0))
'((1 2 3) . ("a" "b"))
'((x) . ()))
'((1 2 3) (x) ("a" "b") ())))]
(Repeat Number 3)
(Repeat String 2)
(Repeat 'x 1)
(Repeat undefined-type 0))
'((1 2 3) . ("a" "b"))
'((x) . ()))
'((1 2 3) (x) ("a" "b") ())))]
@subsection{@racket[let]}
@ -710,10 +743,10 @@ them.
2)
(check-equal?: (let () 'x) 'x)
(check-equal?: (ann (let #:∀ (T) ([a : T 3]
[b : (Pairof T T) '(5 . 7)])
(cons a b))
(Pairof Number (Pairof Number Number)))
'(3 5 . 7))]
[b : (Pairof T T) '(5 . 7)])
(cons a b))
(Pairof Number (Pairof Number Number)))
'(3 5 . 7))]
@subsection{@racket[let*]}
@ -735,9 +768,9 @@ them.
(range (syntax->datum #'n))))]))
(check-equal?: (let* ([x* : (Repeat Number 3) '(1 2 3)]
[y* : (Repeat Number 3) x*])
y*)
'(1 2 3)))]
[y* : (Repeat Number 3) x*])
y*)
'(1 2 3)))]
@subsection{@racket[let-values]}
@ -759,25 +792,25 @@ them.
(range (syntax->datum #'n))))]))
(check-equal?: (ann (let-values
([([x : (Repeat Number 3)])
(list 1 2 3)])
(cdr x))
(List Number Number))
'(2 3))
([([x : (Repeat Number 3)])
(list 1 2 3)])
(cdr x))
(List Number Number))
'(2 3))
(check-equal?: (ann (let-values
([([x : (Repeat Number 3)] [y : Number])
(values (list 1 2 3) 4)])
(cons y x))
(Pairof Number (List Number Number Number)))
'(4 . (1 2 3)))
([([x : (Repeat Number 3)] [y : Number])
(values (list 1 2 3) 4)])
(cons y x))
(Pairof Number (List Number Number Number)))
'(4 . (1 2 3)))
(check-equal?: (ann (let-values
([(x y)
(values (list 1 2 3) 4)])
(cons y x))
(Pairof Number (List Number Number Number)))
'(4 . (1 2 3))))]
([(x y)
(values (list 1 2 3) 4)])
(cons y x))
(Pairof Number (List Number Number Number)))
'(4 . (1 2 3))))]
@subsection{@racket[make-predicate]}
@ -945,17 +978,18 @@ To get around that problem, we define @tc[:] in a separate module, and
Since our @tc[new-:] macro needs to call the @tc[type-expander], and the other
forms too, we can't define @tc[type-expander] in the same module as these forms,
it needs to be either in the same module as @tc[new-:], or in a separate module.
Additionally, expand-type needs to be required @tc[for-syntax] by the forms, but
needs to be @tc[provide]d too, so it is much easier if it is defined in a
separate module (that should be used only @tc[for-syntax], so it will be written
in @tc[racket], not @tc[typed/racket]).
Additionally, @tc[expand-type] needs to be required @tc[for-syntax] by the
forms, but needs to be @tc[provide]d too, so it is much easier if it is defined
in a separate module (that will be used only by macros, so it will be written in
@tc[racket], not @tc[typed/racket]).
@chunk[<module-expander>
(module expander racket
(require racket
syntax/parse
syntax/stx
racket/format)
racket/format
"../lib/low-untyped.rkt")
(require (for-template typed/racket))
@ -1013,7 +1047,7 @@ We can finally define the overloaded forms, as well as the extra
(begin-for-syntax
<template-metafunctions>
<syntax-classes>
(provide colon))
<define-type>
@ -1041,7 +1075,7 @@ And, last but not least, we will add a @tc[test] module.
"../lib/low-untyped.rkt"))
<test-expand-type>
#|
<test-:>
<test-define-type>
@ -1050,7 +1084,7 @@ And, last but not least, we will add a @tc[test] module.
|#
;<test-struct>
<test-define-struct/exec>
#|
#|
<test-ann>
<test-inst>
<test-let>