diff --git a/graph/graph/__DEBUG_graph__.rkt b/graph/graph/__DEBUG_graph__.rkt index 31f62900..76c5675a 100644 --- a/graph/graph/__DEBUG_graph__.rkt +++ b/graph/graph/__DEBUG_graph__.rkt @@ -26,13 +26,15 @@ (require "../lib/low.rkt") (require "../type-expander/type-expander.lp2.rkt") +(get '((1 2) (3)) … …) (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)) +(get g streets … houses … owner name) +((λget streets … houses … owner name) g) +;(map: (λget houses … owner name) (get g streets)) #| diff --git a/graph/graph/graph4.lp2.rkt b/graph/graph/graph4.lp2.rkt index 31fa0202..aa4f7875 100644 --- a/graph/graph/graph4.lp2.rkt +++ b/graph/graph/graph4.lp2.rkt @@ -1,4 +1,4 @@ -#lang scribble/lp2 +#lang debug scribble/lp2 @(require "../lib/doc.rkt") @doc-lib-setup @@ -16,6 +16,12 @@ more than 4 letters. @CHUNK[ (define-syntax-class c…r + #:attributes ([expanded 1] [reverse-expanded 1]) + (pattern :c…r1 + #:with (reverse-expanded …) + (reverse (syntax->list #'(expanded …))))) + + (define-syntax-class c…r1 ;(pattern (~literal car) #:with (expanded …) #'(car)) ;(pattern (~literal cdr) #:with (expanded …) #'(cdr)) (pattern (~literal caar) #:with (expanded …) #'(car car)) @@ -67,20 +73,40 @@ otherwise throw an error: (raise-syntax-error 'c*r "expected a or d" #'id)] @chunk[ - (define-syntax (get stx) - (syntax-parse stx - [(_ v:expr) - #'v] - [(_ 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 …)] - [(_ v:expr field other-fields:id …) - #'(let ([v-cache v]) - (cond - - ))]))] + (define-multi-id has-get + #:type-expander ) + (define-multi-id result-get + #:type-expander ) + (define-multi-id get + ;#:type-expander + #:call + (λ (stx) + (syntax-parse stx + [(_ v:expr) + #'v] + [(_ 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 c…r.reverse-expanded … other-fields …)] + [(_ v:expr (~literal …) other-fields …) + #;#'((map:: T + (result-get T other-fields …) + (has-get T other-fields …) + (λget other-fields …)) + v) + #'((λ #:∀ (T) ([l : (Listof (has-get T other-fields …))]) + : (Listof (result-get T other-fields …)) + ((inst map + (result-get T other-fields …) + (has-get T other-fields …)) + (λget other-fields …) + l)) + v)] + [(_ v:expr field other-fields:id …) + #'(let ([v-cache v]) + (cond + + ))])))] @chunk[ [((make-predicate (List Symbol Any)) v-cache) @@ -105,14 +131,10 @@ otherwise throw an error: @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)))]))] + [(_ field-or-accessor …) + #'(ann (λ (v) (get v field-or-accessor …)) + (∀ (T) (→ (has-get T field-or-accessor …) + (result-get T field-or-accessor …))))]))] The type for the function generated by @tc[λget] mirrors the cases from @tc[get]. @@ -135,19 +157,43 @@ The type for the function generated by @tc[λget] mirrors the cases from @; (Promise (U S (List Symbol S))) @; (→ (maybe-wrapped S) unforgeable))))] -@chunk[<λget-type-helper> - (define-type-expander (λget-type-helper stx) +@chunk[ + (λ (stx) (syntax-parse stx - [(_ T:expr) - #'T] - [(_ T:expr field:id other-fields:id …) - #;#'(U - (List Symbol ) - (Promise (U (List Symbol )))) - #'(Promise (List Symbol ))]))] + [(_ T:expr) #'T] + + ))] -@chunk[ - (structure-supertype [field (λget-type-helper T other-fields …)])] +@chunk[ + ;; TODO: car, cdr, c…r. + [(_ T:expr (~literal car) other-fields:id …) + #'(Pairof (has-get T other-fields …) Any)] + [(_ T:expr (~literal cdr) other-fields:id …) + #'(Pairof Any (has-get T other-fields …))] + [(_ T:expr c…r:c…r other-fields:id …) + #'(has-get T c…r.reverse-expanded … other-fields …)] + [(_ T:expr (~literal …) other-fields:id …) + #'(Listof (has-get T other-fields …))]] + +@chunk[ + [(_ T:expr field:id other-fields:id …) + #'(Promise + (List Symbol + (structure-supertype [field : (has-get T other-fields …)])))]] + +@chunk[ + (λ (stx) + (syntax-parse stx + [(_ T:expr) #'T] + [(_ T:expr (~literal …) other-fields:id …) + #'(Listof (result-get T other-fields …))] + [(_ T:expr + (~or (~lit car) + (~lit cdr) + :c…r + field:id) + other-fields:id …) + #'(result-get T other-fields …)]))] @section{Conclusion} @@ -160,22 +206,24 @@ The type for the function generated by @tc[λget] mirrors the cases from "structure.lp2.rkt" "variant.lp2.rkt" "graph3.lp2.rkt" + "../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.lp2.rkt") (provide get - λget) + λget + has-get + result-get) (begin-for-syntax ) - <λget-type-helper> <λget>)] @chunk[ (module* test typed/racket (require (submod "..") typed/rackunit) - + (require (submod ".." doc)))] diff --git a/graph/graph/map.rkt b/graph/graph/map.rkt index 270010bf..5e6f2c66 100644 --- a/graph/graph/map.rkt +++ b/graph/graph/map.rkt @@ -1,7 +1,8 @@ #lang typed/racket (require (for-syntax syntax/parse) - "../lib/low.rkt") + "../lib/low.rkt" + "map1.rkt") (provide map:) @@ -9,18 +10,16 @@ (define-syntax-class lam (pattern (~or (~literal λ) (~literal lambda))))) -(define-syntax-rule (map:: TVar Element-Type f l) - ((λ #:∀ (TVar) ([lst : (Listof Element-Type)]) - ((inst map TVar Element-Type) f lst)) l)) - (define-syntax (map: stx) (syntax-parse stx - [(_ (~literal car) l) #'(map:: A (Pairof A Any) car l)] - [(_ (~literal cdr) l) #'(map:: B (Pairof Any B) cdr l)] + [(_ (~literal car) l) #'((curry-map A A (Pairof A Any) car) l)] + [(_ (~literal cdr) l) #'((curry-map B B (Pairof Any B) cdr) l)] ;; TODO: add caar etc. [(_ ((~literal values)) l) #'l] [(_ ((~literal compose)) l) #'l] [(_ ((~literal compose) f0 . fs) l) #'(map: f0 (map: (compose . fs) l))] + [(_ ((~literal curry) map: f) l) + #''_] [(_ f . ls) #'(map f . ls)])) diff --git a/graph/graph/map1.rkt b/graph/graph/map1.rkt new file mode 100644 index 00000000..b078844b --- /dev/null +++ b/graph/graph/map1.rkt @@ -0,0 +1,33 @@ +#lang typed/racket + +(require (for-syntax syntax/parse + "../lib/low-untyped.rkt")) + +(provide curry-map) + +(begin-for-syntax + (define-syntax-class curry-map-rec + #:attributes (inner bottom bottom? wrap) + (pattern ((~lit curry) (~lit map) inner:curry-map-rec) + #:attr wrap (λ (x w) (w ((attribute inner.wrap) x w))) + #:attr bottom #'inner.bottom + #:attr bottom? #f) + (pattern f + #:attr wrap (λ (x w) x) + #:attr bottom #'f + #:attr bottom? #t + #:attr inner #f))) + +(define-syntax (curry-map stx) + (syntax-parse stx + [(_ TVar Result-Type Element-Type f:curry-map-rec) + (if (attribute f.bottom?) + #'(ann (λ (l) ((inst map Result-Type Element-Type) f l)) + (∀ (TVar) (→ (Listof Element-Type) + (Listof Result-Type)))) + #`(curry-map TVar + #,((attribute f.wrap) #'Result-Type + (λ (t) #`(Listof #,t))) + #,((attribute f.wrap) #'Element-Type + (λ (t) #`(Listof #,t))) + (curry-map TVar Result-Type Element-Type f.inner)))])) \ No newline at end of file diff --git a/graph/graph/structure.lp2.rkt b/graph/graph/structure.lp2.rkt index e986d4ea..20046f8a 100644 --- a/graph/graph/structure.lp2.rkt +++ b/graph/graph/structure.lp2.rkt @@ -318,7 +318,7 @@ The fields in @tc[fields→stx-name-alist] are already sorted. @chunk[ (define-multi-id structure-supertype #:type-expander - (λ/syntax-parse (_ [field:id type:expr] …) + (λ/syntax-parse (_ [field:id (~optional (~lit :)) type:expr] …) (define/with-syntax ([(all-field …) . _] …) (fields→supertypes #'(field …))) (template