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

Handling lists in get and λget: ((λget streets … houses … owner name) g) now works, so does (get g streets … houses … owner name). Worked a bit more on the inference-friendly macro.

Browse Source
This commit is contained in:
Georges Dupéron 2015-12-18 17:14:39 +01:00
parent 22caa0dba3
commit 22c7e1ea4e
5 changed files with 129 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
graph/graph/__DEBUG_graph__.rkt
View File

@ -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))
#|

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

@ -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[<c…r-syntax-class>
(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[<get>
(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 <get-tagged>
<get-promise>
<get-plain-struct>))]))]
(define-multi-id has-get
#:type-expander <type-for-get>)
(define-multi-id result-get
#:type-expander <result-type-for-get>)
(define-multi-id get
;#:type-expander <type-for-get>
#: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 <get-tagged>
<get-promise>
<get-plain-struct>))])))]
@chunk[<get-tagged>
[((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[<type-for-get>
(λ (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>))]))]
[(_ T:expr) #'T]
<type-for-get-pairs>
<type-for-get-field>))]
@chunk[<r>
(structure-supertype [field (λget-type-helper T other-fields …)])]
@chunk[<type-for-get-pairs>
;; 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[<type-for-get-field>
[(_ T:expr field:id other-fields:id …)
#'(Promise
(List Symbol
(structure-supertype [field : (has-get T other-fields …)])))]]
@chunk[<result-type-for-get>
(λ (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
<c…r-syntax-class>)
<get>
<λget-type-helper>
<λget>)]
@chunk[<module-test>
(module* test typed/racket
(require (submod "..")
typed/rackunit)
<test-get>
(require (submod ".." doc)))]

13
graph/graph/map.rkt
View File

@ -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)]))

33
graph/graph/map1.rkt Normal file
View File

@ -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)))]))

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

@ -318,7 +318,7 @@ 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 type:expr] …)
(λ/syntax-parse (_ [field:id (~optional (~lit :)) type:expr] …)
(define/with-syntax ([(all-field …) . _] …)
(fields→supertypes #'(field …)))
(template