Implemented (get v f …) with support for c[ad]*r. Fixed naming of types returned by struct-get (by not defining types for fields, in case they're the same as a node type or built-in type)
This commit is contained in:
Georges Dupéron
parent
01ef3f2c01
commit
6e5bc55402
|
|
@ -19,15 +19,23 @@
|
|||
|#
|
||||
|
||||
(require (submod "graph3.lp2.rkt" test))
|
||||
(require "graph4.lp2.rkt")
|
||||
(require "structure.lp2.rkt")
|
||||
(require "variant.lp2.rkt")
|
||||
(require "../lib/low.rkt")
|
||||
(require racket/list)
|
||||
|
||||
;(structure-get people)
|
||||
(structure-get (cadr g) people)
|
||||
(get g people)
|
||||
(get g streets cadr houses car owner name)
|
||||
|
||||
#|
|
||||
(define #:∀ (A) (map-force [l : (Listof (Promise A))])
|
||||
(map (inst force A) l))
|
||||
|
||||
(map-force (get g people))
|
||||
(map-force (get g streets))
|
||||
|#
|
||||
|
||||
#|
|
||||
(let ()
|
||||
|
|
|
|||
|
|
@ -211,13 +211,11 @@ We derive identifiers for these based on the @tc[node] name:
|
|||
(define-temp-ids "~a/incomplete-type" (node …))
|
||||
(define-temp-ids "~a/make-incomplete" (node …))
|
||||
(define-temp-ids "~a/incomplete-tag" (node …))
|
||||
(define-temp-ids "~a/incomplete-type" ((field …) …))
|
||||
|
||||
(define-temp-ids "~a/with-indices-type" (node …))
|
||||
(define-temp-ids "~a/make-with-indices" (node …))
|
||||
(define-temp-ids "~a/with-indices-tag" (node …))
|
||||
(define-temp-ids "~a/with-indices-tag2" (node …))
|
||||
(define-temp-ids "~a/with-indices-type" ((field …) …))
|
||||
(define-temp-ids "~a/index-type" (node …))
|
||||
(define-temp-ids "~a/with-indices→with-promises" (node …)
|
||||
#:first-base root)
|
||||
|
|
@ -225,7 +223,6 @@ We derive identifiers for these based on the @tc[node] name:
|
|||
(define-temp-ids "~a/with-promises-type" (node …) #:first-base root)
|
||||
(define-temp-ids "~a/make-with-promises" (node …))
|
||||
(define-temp-ids "~a/with-promises-tag" (node …))
|
||||
(define-temp-ids "~a/with-promises-type" ((field …) …))
|
||||
|
||||
(define-temp-ids "~a/mapping-function" (node …))
|
||||
|
||||
|
|
@ -346,18 +343,17 @@ indicates at which index in the queue's results the successor can be found.
|
|||
@CHUNK[<define-with-indices>
|
||||
(define-type node/index-type (List 'node/with-indices-tag2 Index))
|
||||
|
||||
(define-type field/with-indices-type
|
||||
(tmpl-replace-in-type field-type [node node/index-type] …))
|
||||
…
|
||||
|
||||
(define-type node/with-indices-type
|
||||
(List 'node/with-indices-tag field/with-indices-type …))
|
||||
(List 'node/with-indices-tag <field/with-indices-type> …))
|
||||
|
||||
(: node/make-with-indices (→ field/with-indices-type …
|
||||
(: node/make-with-indices (→ <field/with-indices-type> …
|
||||
node/with-indices-type))
|
||||
(define (node/make-with-indices field …)
|
||||
(list 'node/with-indices-tag field …))]
|
||||
|
||||
@CHUNK[<field/with-indices-type>
|
||||
(tmpl-replace-in-type field-type [node node/index-type] …)]
|
||||
|
||||
@subsection{Making with-promises nodes}
|
||||
|
||||
We derive the @tc[with-promises] type from each @emph{ideal} node type using
|
||||
|
|
@ -368,22 +364,22 @@ that node's @tc[with-promises] type.
|
|||
@; TODO: use a type-expander here, instead of a template metafunction.
|
||||
|
||||
@CHUNK[<define-with-promises>
|
||||
(define-type field/with-promises-type
|
||||
(tmpl-replace-in-type field-type
|
||||
[node (Promise node/with-promises-type)] …))
|
||||
…
|
||||
|
||||
(define-type node/with-promises-type
|
||||
(tagged node/with-promises-tag
|
||||
[field : field/with-promises-type] …))
|
||||
[field : <field/with-promises-type>] …))
|
||||
|
||||
(: node/make-with-promises (→ field/with-promises-type …
|
||||
(: node/make-with-promises (→ <field/with-promises-type> …
|
||||
node/with-promises-type))
|
||||
(define (node/make-with-promises field/value …)
|
||||
(tagged node/with-promises-tag
|
||||
[field : field/with-promises-type field/value]
|
||||
[field : <field/with-promises-type> field/value]
|
||||
…))]
|
||||
|
||||
@CHUNK[<field/with-promises-type>
|
||||
(tmpl-replace-in-type field-type
|
||||
[node (Promise node/with-promises-type)] …)]
|
||||
|
||||
@subsection{Making incomplete nodes}
|
||||
|
||||
We derive the @tc[incomplete] type from each @emph{ideal} node type using
|
||||
|
|
@ -394,18 +390,18 @@ library. We replace all occurrences of a @tc[node] name with its
|
|||
@; TODO: use a type-expander here, instead of a template metafunction.
|
||||
|
||||
@CHUNK[<define-incomplete>
|
||||
(define-type field/incomplete-type
|
||||
(tmpl-replace-in-type field-type
|
||||
[node node/placeholder-type] …))
|
||||
…
|
||||
|
||||
(define-type node/incomplete-type
|
||||
(List 'node/incomplete-tag field/incomplete-type …))
|
||||
(List 'node/incomplete-tag <field/incomplete-type> …))
|
||||
|
||||
(: node/make-incomplete (→ field/incomplete-type … node/incomplete-type))
|
||||
(: node/make-incomplete (→ <field/incomplete-type> …
|
||||
node/incomplete-type))
|
||||
(define (node/make-incomplete field …)
|
||||
(list 'node/incomplete-tag field …))]
|
||||
|
||||
@CHUNK[<field/incomplete-type>
|
||||
(tmpl-replace-in-type field-type
|
||||
[node node/placeholder-type] …)]
|
||||
|
||||
@subsection{Converting incomplete nodes to with-indices ones}
|
||||
|
||||
@; TODO: we don't need that many annotations
|
||||
|
|
|
|||
135
graph/graph/graph4.lp2.rkt
Normal file
135
graph/graph/graph4.lp2.rkt
Normal file
|
|
@ -0,0 +1,135 @@
|
|||
#lang scribble/lp2
|
||||
@(require "../lib/doc.rkt")
|
||||
@doc-lib-setup
|
||||
|
||||
@title[#:style manual-doc-style]{Syntactic sugar for the @racket[graph] macro}
|
||||
|
||||
@(table-of-contents)
|
||||
|
||||
@section{Introduction}
|
||||
|
||||
We allow not just identifiers having the @tc[c…r] syntax, but also those
|
||||
matching one of the predefined identifiers, so that @tc[(rename-in [car hd])]
|
||||
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>
|
||||
(define-syntax-class c…r
|
||||
;(pattern (~literal car) #:with (expanded …) #'(car))
|
||||
;(pattern (~literal cdr) #:with (expanded …) #'(cdr))
|
||||
(pattern (~literal caar) #:with (expanded …) #'(car car))
|
||||
(pattern (~literal cdar) #:with (expanded …) #'(cdr car))
|
||||
(pattern (~literal cadr) #:with (expanded …) #'(car cdr))
|
||||
(pattern (~literal cddr) #:with (expanded …) #'(cdr cdr))
|
||||
(pattern (~literal caaar) #:with (expanded …) #'(car car car))
|
||||
(pattern (~literal cdaar) #:with (expanded …) #'(cdr car car))
|
||||
(pattern (~literal cadar) #:with (expanded …) #'(car cdr car))
|
||||
(pattern (~literal cddar) #:with (expanded …) #'(cdr cdr car))
|
||||
(pattern (~literal caadr) #:with (expanded …) #'(car car cdr))
|
||||
(pattern (~literal cdadr) #:with (expanded …) #'(cdr car cdr))
|
||||
(pattern (~literal caddr) #:with (expanded …) #'(car cdr cdr))
|
||||
(pattern (~literal cdddr) #:with (expanded …) #'(cdr cdr cdr))
|
||||
(pattern (~literal caaaar) #:with (expanded …) #'(car car car car))
|
||||
(pattern (~literal cdaaar) #:with (expanded …) #'(cdr car car car))
|
||||
(pattern (~literal cadaar) #:with (expanded …) #'(car cdr car car))
|
||||
(pattern (~literal cddaar) #:with (expanded …) #'(cdr cdr car car))
|
||||
(pattern (~literal caadar) #:with (expanded …) #'(car car cdr car))
|
||||
(pattern (~literal cdadar) #:with (expanded …) #'(cdr car cdr car))
|
||||
(pattern (~literal caddar) #:with (expanded …) #'(car cdr cdr car))
|
||||
(pattern (~literal cdddar) #:with (expanded …) #'(cdr cdr cdr car))
|
||||
(pattern (~literal caaadr) #:with (expanded …) #'(car car car cdr))
|
||||
(pattern (~literal cdaadr) #:with (expanded …) #'(cdr car car cdr))
|
||||
(pattern (~literal cadadr) #:with (expanded …) #'(car cdr car cdr))
|
||||
(pattern (~literal cddadr) #:with (expanded …) #'(cdr cdr car cdr))
|
||||
(pattern (~literal caaddr) #:with (expanded …) #'(car car cdr cdr))
|
||||
(pattern (~literal cdaddr) #:with (expanded …) #'(cdr car cdr cdr))
|
||||
(pattern (~literal cadddr) #:with (expanded …) #'(car cdr cdr cdr))
|
||||
(pattern (~literal cddddr) #:with (expanded …) #'(cdr cdr cdr cdr))
|
||||
(pattern id:id
|
||||
#:when (regexp-match #rx"^c[ad][ad]*r$"
|
||||
(identifier→string #'id))
|
||||
#:with (expanded …)
|
||||
(map (λ (c)
|
||||
(cond [(equal? c #\a) #'car]
|
||||
[(equal? c #\d) #'cdr]
|
||||
[<c*r-error>]))
|
||||
(string->list
|
||||
(cadr
|
||||
(regexp-match #rx"^c([ad][ad]*)r$"
|
||||
(identifier→string #'id)))))))]
|
||||
|
||||
Although this should not happen, by construction, we check for both cases
|
||||
(@tc[#\a] and @tc[#\d]) for each character of a @tc[c…r] identifier, and
|
||||
otherwise throw an error:
|
||||
|
||||
@chunk[<c*r-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>))]))]
|
||||
|
||||
@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 …)]]
|
||||
|
||||
@chunk[<test-get>
|
||||
(check-equal? 'TODO 'TODO)]
|
||||
|
||||
@section{Conclusion}
|
||||
|
||||
@chunk[<module-main>
|
||||
(module main typed/racket
|
||||
(require (for-syntax syntax/parse
|
||||
racket/syntax
|
||||
"../lib/low-untyped.rkt")
|
||||
"../lib/low.rkt"
|
||||
"structure.lp2.rkt"
|
||||
"variant.lp2.rkt"
|
||||
"graph3.lp2.rkt")
|
||||
(provide get)
|
||||
|
||||
(begin-for-syntax
|
||||
<c*r-syntax-class>)
|
||||
|
||||
<get>)]
|
||||
|
||||
@chunk[<module-test>
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
typed/rackunit)
|
||||
|
||||
<test-get>
|
||||
|
||||
(require (submod ".." doc)))]
|
||||
|
||||
@chunk[<*>
|
||||
(begin
|
||||
<module-main>
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
||||
<module-test>)]
|
||||
|
|
@ -137,21 +137,23 @@ Test constructor:
|
|||
|
||||
@chunk[<test-define-structure>
|
||||
(check-equal?: (empty-st) : empty-st (empty-st))
|
||||
(check-equal?: (get (st 1 "b") b) : String "b")
|
||||
(check-equal?: (get (st2 "a" 2) b) : String "a")]
|
||||
(check-equal?: (structure-get (st 1 "b") b) : String "b")
|
||||
(check-equal?: (structure-get (st2 "a" 2) b) : String "a")]
|
||||
|
||||
Test constructor, as id:
|
||||
|
||||
@chunk[<test-define-structure>
|
||||
(check-equal?: (get (cadr (map st '(1 2 3) '("x" "y" "z"))) b) : String
|
||||
(check-equal?: (structure-get (cadr (map st '(1 2 3) '("x" "y" "z"))) b)
|
||||
: String
|
||||
"y")
|
||||
(check-equal?: (get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b) : String
|
||||
(check-equal?: (structure-get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b)
|
||||
: String
|
||||
"e")]
|
||||
|
||||
Test the type-expander:
|
||||
|
||||
@chunk[<test-define-structure>
|
||||
(check-equal? (get (ann (st2 "g" 123) st2) b) "g")]
|
||||
(check-equal? (structure-get (ann (st2 "g" 123) st2) b) "g")]
|
||||
|
||||
Test the match-expander:
|
||||
|
||||
|
|
@ -298,47 +300,72 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
|
|||
(cdr (assoc (syntax->datum (datum->syntax #f (sort-fields fields)))
|
||||
fields→stx-name-alist)))]
|
||||
|
||||
@subsection{Has-field}
|
||||
|
||||
@chunk[<structure-supertype-match-expander>
|
||||
(λ/syntax-parse (_ :match-field-or-field-pat ...)
|
||||
(define/with-syntax ([(all-field …) . name] …)
|
||||
(fields→supertypes #'(field …)))
|
||||
(define/with-syntax ([sorted-field1 …] …)
|
||||
(stx-map sort-fields #'((all-field …) …)))
|
||||
(define/with-syntax ([[sorted-field sorted-pat …] …] …)
|
||||
(stx-map (curry stx-map
|
||||
(λ (x) (multiassoc-syntax x #'([field pat …] …))))
|
||||
#'((sorted-field1 …) …)))
|
||||
#'(or (name (and sorted-field sorted-pat …) …) …))]
|
||||
|
||||
@chunk[<structure-supertype>
|
||||
(define-multi-id structure-supertype
|
||||
#:type-expander
|
||||
(λ/syntax-parse (_ field:id …)
|
||||
#`(U #,@(map cdr (fields→supertypes #'(field …)))))
|
||||
#:match-expander <structure-supertype-match-expander>)]
|
||||
|
||||
@chunk[<fields→supertypes>
|
||||
(define-for-syntax (fields→supertypes stx-fields)
|
||||
(with-syntax ([(field …) stx-fields])
|
||||
(foldl (λ (f alist)
|
||||
(filter (λ (s) (member (syntax->datum f) (car s)))
|
||||
alist))
|
||||
fields→stx-name-alist
|
||||
(syntax->list #'(field …)))))]
|
||||
|
||||
@subsection{Accessor}
|
||||
|
||||
@CHUNK[<get-field2>
|
||||
(define-syntax (get stx)
|
||||
(syntax-parse stx
|
||||
[(_ v field:id)
|
||||
(define struct-names
|
||||
(filter (λ (s)
|
||||
(member (syntax->datum #'field) (car s)))
|
||||
fields→stx-name-alist))
|
||||
(define/with-syntax (name? ...)
|
||||
(map (λ (s) <get-predicate>) struct-names))
|
||||
(define/with-syntax (name-field ...)
|
||||
(map (λ (s) <get-field-accessor>) struct-names))
|
||||
#`(let ([v-cache v])
|
||||
(cond
|
||||
[(name? v-cache)
|
||||
(let ([accessor name-field])
|
||||
(accessor v-cache))]; cover doesn't see the call otherwise?
|
||||
…
|
||||
;; For variants:
|
||||
;; If we hit the bug where refinements cause loss of precision
|
||||
;; in later clauses, then just use separate functions, forming
|
||||
;; a BTD:
|
||||
;; (λ ([x : (U A1 A2 A3 B1 B2 B3)]) (if (A? x) (fa x) (fb x)))
|
||||
[(and (pair? v-cache)
|
||||
(symbol? (car v-cache))
|
||||
(null? (cddr v-cache))
|
||||
(name? (cadr v-cache)))
|
||||
(let ([accessor name-field])
|
||||
(accessor (cadr v-cache)))]
|
||||
…
|
||||
[else (typecheck-fail #,stx #:covered-id v-cache)]))]
|
||||
[(_ field:id)
|
||||
(define/with-syntax (struct-name …)
|
||||
(filter (λ (s)
|
||||
(member (syntax->datum #'field) (car s)))
|
||||
fields→stx-name-alist))
|
||||
#'(λ ([v : (U struct-name …
|
||||
(List Symbol struct-name) …)])
|
||||
(get v field))]))]
|
||||
@CHUNK[<get-field>
|
||||
(define-syntax/parse (structure-get v field:id)
|
||||
(define structs (fields→supertypes #'(field)))
|
||||
(define/with-syntax (name? ...)
|
||||
(map (λ (s) <get-predicate>) structs))
|
||||
(define/with-syntax (name-field ...)
|
||||
(map (λ (s) <get-field-accessor>) structs))
|
||||
#`(let ([v-cache v])
|
||||
(cond
|
||||
;; If we hit the bug where refinements cause loss of precision
|
||||
;; in later clauses, then just use separate functions, forming
|
||||
;; a BTD:
|
||||
;; (λ ([x : (U A1 A2 A3 B1 B2 B3)]) (if (A? x) (fa x) (fb x)))
|
||||
[(name? v-cache)
|
||||
(let ([accessor name-field])
|
||||
(accessor v-cache))]; cover doesn't see the call otherwise?
|
||||
…
|
||||
[else (typecheck-fail #,stx #:covered-id v-cache)])))]
|
||||
|
||||
@CHUNK[<get-field>
|
||||
(define-syntax/parse (λstructure-get field:id)
|
||||
(define/with-syntax ([(all-field …) . name] …)
|
||||
(fields→supertypes #'(field)))
|
||||
(define-temp-ids "~a/T" field)
|
||||
(define/syntax-parse ([all-field/T …] …)
|
||||
(stx-map (curry stx-map
|
||||
(λ (f)
|
||||
(if (free-identifier=? f #'field)
|
||||
#'field/T
|
||||
#'Any)))
|
||||
#'([all-field …] …)))
|
||||
#'(λ #:∀ (field/T)
|
||||
([v : (U [(structure [all-field : all-field/T]) …] …)])
|
||||
(structure-get v field)))]
|
||||
|
||||
@chunk[<get-predicate>
|
||||
(my-st-type-info-predicate (get-struct-info stx (cdr s)))]
|
||||
|
|
@ -349,9 +376,9 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
|
|||
|
||||
@chunk[<test-get-field>
|
||||
(check-equal?:
|
||||
(get ((make-structure-constructor a b c d) 1 "b" 'value-c 4) c)
|
||||
: 'value-c
|
||||
'value-c)]
|
||||
(structure-get ((make-structure-constructor a b c d) 1 "b" 'val-c 4) c)
|
||||
: 'val-c
|
||||
'val-c)]
|
||||
|
||||
@subsection{Match-expander}
|
||||
|
||||
|
|
@ -362,7 +389,6 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
|
|||
(pattern field:id #:with (pat ...) #'())))]
|
||||
|
||||
@chunk[<match-expander>
|
||||
<syntax-class-for-match>
|
||||
(define-for-syntax (structure-match-expander stx)
|
||||
(syntax-parse stx
|
||||
[(_ :match-field-or-field-pat ...)
|
||||
|
|
@ -460,10 +486,11 @@ instead of needing an extra recompilation.
|
|||
(remember-all-errors #'U stx #'(field ...)))]))]
|
||||
|
||||
@chunk[<test-type-expander>
|
||||
(check-equal? (get (ann ((make-structure-constructor a b c) 1 "b" #t)
|
||||
(structure [a Number] [c Boolean] [b String]))
|
||||
b)
|
||||
"b")]
|
||||
(check-equal?
|
||||
(structure-get (ann ((make-structure-constructor a b c) 1 "b" #t)
|
||||
(structure [a Number] [c Boolean] [b String]))
|
||||
b)
|
||||
"b")]
|
||||
|
||||
@section[#:tag "structure|remember"]{Closed-world assumption and global
|
||||
compilation}
|
||||
|
|
@ -546,14 +573,17 @@ chances that we could write a definition for that identifier.
|
|||
racket/sequence
|
||||
;; in-syntax on older versions:
|
||||
;;;unstable/sequence
|
||||
"../lib/low-untyped.rkt")
|
||||
"../lib/low-untyped.rkt"
|
||||
"../lib/low/multiassoc-syntax.rkt")
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt")
|
||||
(provide define-structure
|
||||
make-structure-constructor
|
||||
get
|
||||
structure)
|
||||
structure-get
|
||||
λstructure-get
|
||||
structure
|
||||
structure-supertype)
|
||||
|
||||
(begin-for-syntax
|
||||
(provide structure-args-stx-class))
|
||||
|
|
@ -572,9 +602,11 @@ chances that we could write a definition for that identifier.
|
|||
|
||||
<my-st-type-info>
|
||||
<struct-info>
|
||||
<get-field2>
|
||||
;<get-field>
|
||||
<fields→supertypes>
|
||||
<get-field>
|
||||
|
||||
<syntax-class-for-match>
|
||||
<structure-supertype>
|
||||
<match-expander>
|
||||
<type-expander>
|
||||
|
||||
|
|
|
|||
|
|
@ -160,6 +160,16 @@ number of name collisions.
|
|||
#'(c sa.value …)
|
||||
#'c)))]
|
||||
|
||||
@CHUNK[<tagged>
|
||||
(define-multi-id any-tagged
|
||||
#:type-expander
|
||||
(λ/syntax-parse (_ . structure-type)
|
||||
#'(List Symbol (structure . structure-type)))
|
||||
#:match-expander
|
||||
(λ/syntax-parse (_ tag-pat:id . structure-pat)
|
||||
#`(list (? symbol? tag-pat:id) #,(syntax/loc #'structure-pat
|
||||
(structure . structure-pat)))))]
|
||||
|
||||
@chunk[<test-tagged>
|
||||
(check-equal? (match (ann (tagged foo [x "o"] [y 3] [z 'z])
|
||||
(tagged foo
|
||||
|
|
@ -279,7 +289,8 @@ number of name collisions.
|
|||
(provide constructor
|
||||
define-variant
|
||||
tagged
|
||||
define-tagged)
|
||||
define-tagged
|
||||
any-tagged)
|
||||
|
||||
<constructor>
|
||||
<define-variant>
|
||||
|
|
|
|||
|
|
@ -46,25 +46,31 @@ scribble, see
|
|||
|
||||
@section{Conclusion}
|
||||
|
||||
@chunk[<module-main>
|
||||
(module main typed/racket
|
||||
(require (for-syntax syntax/parse
|
||||
racket/syntax
|
||||
"../../lib/low-untyped.rkt")
|
||||
"../../lib/low-untyped.rkt")
|
||||
(provide foo)
|
||||
|
||||
<foo>
|
||||
<scribble-macro-expansion>)]
|
||||
|
||||
@chunk[<module-test>
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
typed/rackunit)
|
||||
|
||||
<test-foo>
|
||||
|
||||
(require (submod ".." doc)))]
|
||||
|
||||
@chunk[<*>
|
||||
(begin
|
||||
(module main typed/racket
|
||||
(require (for-syntax syntax/parse
|
||||
racket/syntax
|
||||
"../../lib/low-untyped.rkt")
|
||||
"../../lib/low-untyped.rkt")
|
||||
(provide foo)
|
||||
|
||||
<foo>
|
||||
<scribble-macro-expansion>)
|
||||
<module-main>
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
typed/rackunit)
|
||||
|
||||
<test-foo>
|
||||
|
||||
(require (submod ".." doc))))]
|
||||
<module-test>)]
|
||||
|
|
@ -17,12 +17,6 @@
|
|||
(require (for-syntax syntax/parse
|
||||
racket/syntax))
|
||||
|
||||
;; raco pkg install alexis-util
|
||||
(require alexis/util/threading)
|
||||
|
||||
;; From alexis/util/threading
|
||||
(provide ~> ~>> _ (rename-out [_ ♦]))
|
||||
|
||||
(define-syntax (comment stx)
|
||||
#'(values))
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,17 @@
|
|||
(: degub (∀ (T) (→ T T)))
|
||||
(define (degub x) (display "degub:") (displayln x) x)
|
||||
|
||||
;; ==== low/threading.rkt
|
||||
|
||||
;; raco pkg install alexis-util
|
||||
;; or:
|
||||
;; raco pkg install threading
|
||||
(require alexis/util/threading)
|
||||
|
||||
(define-syntax-rule (~>_ clause ... expr) (~> expr clause ...))
|
||||
|
||||
(provide ~>_ ~> ~>> _ (rename-out [_ ♦]))
|
||||
|
||||
;; ==== low/typed-untyped-module.rkt ====
|
||||
|
||||
(require typed/untyped-utils)
|
||||
|
|
@ -299,6 +310,7 @@
|
|||
*in-split
|
||||
my-in-syntax
|
||||
indexof
|
||||
replace-first
|
||||
Syntax-Listof
|
||||
check-duplicate-identifiers
|
||||
generate-temporary)
|
||||
|
|
@ -535,6 +547,21 @@
|
|||
index
|
||||
(rec (cdr lst) (+ index 1))))))
|
||||
|
||||
(: replace-first (∀ (A B C) (->* (B
|
||||
C
|
||||
(Listof (U A B)))
|
||||
(#:equal? (→ (U A B) (U A B) Any : #:+ B))
|
||||
(Rec R (U (Pairof (U A B) R)
|
||||
Null
|
||||
(Pairof C (Listof (U A B))))))))
|
||||
(define (replace-first from to l #:equal? [equal? eq?])
|
||||
(if (null? l)
|
||||
'()
|
||||
(if (equal? from (car l))
|
||||
(cons to (cdr l))
|
||||
(cons (car l)
|
||||
(replace-first from to (cdr l))))))
|
||||
|
||||
;; See also syntax-e, which does not flatten syntax pairs, and syntax->list,
|
||||
;; which isn't correctly typed (won't take #'(a . (b c d e))).
|
||||
(define-type (Syntax-Listof T)
|
||||
|
|
@ -880,7 +907,10 @@
|
|||
(provide syntax-cons-property
|
||||
stx-assoc
|
||||
cdr-stx-assoc
|
||||
stx-map-nested)
|
||||
stx-map-nested
|
||||
identifier-length
|
||||
identifier->string
|
||||
(rename-out [identifier->string identifier→string]))
|
||||
|
||||
(: syntax-cons-property (∀ (A) (→ (Syntaxof A) Symbol Any (Syntaxof A))))
|
||||
(define (syntax-cons-property stx key v)
|
||||
|
|
@ -889,7 +919,10 @@
|
|||
|
||||
|
||||
(: identifier-length (→ Identifier Index))
|
||||
(define (identifier-length id) (string-length (symbol->string (syntax-e id))))
|
||||
(define (identifier-length id) (string-length (identifier->string id)))
|
||||
|
||||
(: identifier->string (→ Identifier String))
|
||||
(define (identifier->string id) (symbol->string (syntax-e id)))
|
||||
|
||||
(: stx-map-nested (∀ (A B) (→ (→ A B)
|
||||
(Syntaxof (Listof (Syntaxof (Listof A))))
|
||||
|
|
|
|||
23
graph/lib/low/multiassoc-syntax.rkt
Normal file
23
graph/lib/low/multiassoc-syntax.rkt
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
#lang racket
|
||||
|
||||
(require syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
syntax/stx)
|
||||
|
||||
(provide multiassoc-syntax
|
||||
cdr-assoc-syntax
|
||||
tmpl-cdr-assoc-syntax)
|
||||
|
||||
(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))))
|
||||
|
||||
(define-template-metafunction (tmpl-cdr-assoc-syntax stx)
|
||||
(syntax-parse stx
|
||||
[(_ query [k . v] …)
|
||||
(cdr-assoc-syntax #'query #'([k . v] …))]))
|
||||
Loading…
Reference in New Issue
Block a user