diff --git a/graph/graph/graph.lp2.rkt b/graph/graph/graph.lp2.rkt index 478fabd5..ee20603c 100644 --- a/graph/graph/graph.lp2.rkt +++ b/graph/graph/graph.lp2.rkt @@ -8,8 +8,8 @@ This module provides (a simplified form of) recursive algebraic data structures, with the ability to handle the structure as a collection of nodes, and process them all in a way similar to what @tc[map] provides. Traditionally, immutable data structures can't form cycles, but can easily be traversed to reach all -nodes. Conversely, traversing a cyclic data structure (based on lazy evaluation -or thunks) is difficult if at all possible. +nodes. Conversely, iterating over a cyclic data structure (created via lazy +evaluation or thunks) is difficult if at all possible. More formally, this module offers fold operations on heterogeneous, richly typed graphs. diff --git a/graph/graph/rewrite-type.lp2.rkt b/graph/graph/rewrite-type.lp2.rkt index 9ea4e166..de95c40e 100644 --- a/graph/graph/rewrite-type.lp2.rkt +++ b/graph/graph/rewrite-type.lp2.rkt @@ -34,11 +34,17 @@ relies on the lower-level utilities provided by this module, namely @CHUNK[ (define-syntax (make-replace stx) (syntax-case stx () - [(_ name type . replace) + [(_ name type [from to fun] ...) #`(begin - (: name (→ type #,(replace-in-type #'type #'replace))) + (: name (→ type #,(replace-in-type #'type #'([from to] ...)))) (define (name v) - #,(replace-in-instance #'v #'type #'replace)))]))] + #,(replace-in-instance #'v + #'type + #')))]))] + +@CHUNK[ + ([from to (λ ([x : from] [acc : Any]) (fun x))] + ...)] @subsection{A bigger example} @@ -83,7 +89,7 @@ calls itself on the components of the type. @CHUNK[ (define-for-syntax (replace-in-type t r) (define (recursive-replace new-t) (replace-in-type new-t r)) - (define/with-syntax ([from to fun] ...) r) + (define/with-syntax ([from to] ...) r) (syntax-parse t ))] @@ -171,7 +177,7 @@ The other cases are similarly defined: #:with (to-type . to-fun) #'assoc-from-to (define/with-syntax (tmp) (generate-temporaries #'(x))) ;; TODO: Add predicate for to-type in the pattern. - #`(to-fun val)] + #`(to-fun val '())] [((~literal List) a ...) (define/with-syntax (tmp ...) (generate-temporaries #'(a ...))) #`(let-values ([(tmp ...) (apply values val)]) @@ -243,6 +249,80 @@ detail in the "Rethink-how-to-do-the-multi-step-types-more-inside")] {FogBugz case 54}. +@section{Extracting parts of an instance} + +Replacing parts of an instance may require first extracting them. We define here +a general fold over some data structures, that allows the replacement function +to know a value returned by previous replacements. It can be easily adapted to +have each substitution have a different accumulator by using @tc[list] or +@tc[struct] of these accumulators as the main one. + +The order in which the elements of the structure are passed to the substitution +functions is undefined. + +@subsection{Tests} + +@CHUNK[ + (make-fold test-fold + (List String Number (List String String Symbol String)) + Number + [String Number (λ ([x : String] [acc : Number]) + (values (+ (string-length x) acc) + (+ acc 1)))]) + + (test-fold '("a" 7 ("b" "c" x "d")) 0)] + +@CHUNK[ + (define-syntax (make-fold stx) + (syntax-case stx () + [(_ name type acc-type [from to fun] ...) + #`(begin + (: name (→ type + acc-type + (values #,(replace-in-type #'type #'([from to] ...)) + acc-type))) + (define name + #,(fold-instance #'v + #'type + #'acc-type + #'([from to fun] ...))))]))] + +@subsection{The code} + +@CHUNK[ + (define-for-syntax (fold-instance val t stx-acc-type r) + (define/with-syntax acc-type stx-acc-type) + (define/with-syntax ([from to fun] ...) r) + + ; + (recursive-replace t))] + +@CHUNK[ + (define (recursive-replace type) + (define/with-syntax (v-cache) (generate-temporaries #'(val-cache))) + (syntax-parse type + [x:id + #:attr assoc-from-to (cdr-stx-assoc #'x #'((from . (to . fun)) ...)) + #:when (attribute assoc-from-to) + #:with (to-type . to-fun) #'assoc-from-to + (define/with-syntax (tmp) (generate-temporaries #'(x))) + ;; TODO: Add predicate for x-to in the pattern. + #`to-fun] + [((~literal List) a ...) + (define/with-syntax (tmp1 ...) (generate-temporaries #'(a ...))) + (define/with-syntax (tmp2 ...) (generate-temporaries #'(a ...))) + (define/with-syntax (new-acc ...) (generate-temporaries #'(a ...))) + (define/with-syntax (new-acc1 ... new-acc-last) #'(acc new-acc ...)) + (define/with-syntax (rec ...) + (stx-map recursive-replace #'(a ...))) + #`(λ ([val : (List a ...)] [acc : acc-type]) + (let*-values ([(tmp1 ...) (apply values val)] + [(tmp2 new-acc) (rec tmp1 new-acc1)] + ...) + (values (list tmp2 ...) new-acc-last)))] + [x:id + #'values]))] + @section{Conclusion} @chunk[<*> @@ -258,10 +338,12 @@ detail in the "../type-expander/type-expander.lp2.rkt" "cond-abort.rkt") (begin-for-syntax (provide replace-in-type - replace-in-instance)) + replace-in-instance + fold-instance)) - ) + + ) (require 'main) (provide (all-from-out 'main)) @@ -279,4 +361,7 @@ detail in the + + + (require (submod ".." doc))))] \ No newline at end of file diff --git a/graph/lib/low-untyped.rkt b/graph/lib/low-untyped.rkt index 3857c30d..17070d8d 100644 --- a/graph/lib/low-untyped.rkt +++ b/graph/lib/low-untyped.rkt @@ -6,9 +6,10 @@ ;(require sugar/include) ;(include-without-lang-line "low.rkt") -;; typed/racket/no-check does not require (for-syntax racket/base). ;; TODO: file a bug report? +;; typed/racket/no-check does not require (for-syntax racket/base). (require (for-syntax racket/base)) + (include/reader "low.rkt" (λ (source-name in) (port-count-lines! in) (do ()