diff --git a/graph-lib/graph/dotlang.rkt b/graph-lib/graph/dotlang.rkt index dc1473fe..9cabbe8b 100644 --- a/graph-lib/graph/dotlang.rkt +++ b/graph-lib/graph/dotlang.rkt @@ -8,8 +8,9 @@ #%module-begin) (rename-out #;[new-#%top #%top] [new-#%module-begin #%module-begin])) + - (require "graph4.lp2.rkt" + (require "get.lp2.rkt" "../lib/low-untyped.rkt" (for-syntax racket/string syntax/parse @@ -46,7 +47,7 @@ (define-syntax (new-#%module-begin stx) (syntax-case stx () - [(_ . body) + [(_ . body) #`(#%module-begin . #,(fold-syntax replace-dots #'body))])) @@ -108,10 +109,10 @@ (module test (submod ".." dotlang) (require typed/rackunit "../lib/low.rkt" - "graph4.lp2.rkt" - (submod "graph3.lp2.rkt" test) - "map4.rkt") - + "get.lp2.rkt" + (submod "graph.lp2.rkt" test) + "map.rkt") + (let ((foo..bar 42)) (check-equal?: foo..bar 42)) diff --git a/graph-lib/graph/graph4.lp2.rkt b/graph-lib/graph/get.lp2.rkt similarity index 99% rename from graph-lib/graph/graph4.lp2.rkt rename to graph-lib/graph/get.lp2.rkt index b037dae5..44419159 100644 --- a/graph-lib/graph/graph4.lp2.rkt +++ b/graph-lib/graph/get.lp2.rkt @@ -205,7 +205,7 @@ The type for the function generated by @tc[λget] mirrors the cases from "../lib/low.rkt" "structure.lp2.rkt" "variant.lp2.rkt" - "graph3.lp2.rkt" + "graph.lp2.rkt" "../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.lp2.rkt" "map1.rkt") diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index 42a3b6fb..6e4e19b5 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -1,884 +1,655 @@ -#lang scribble/lp2 +#lang debug scribble/lp2 @(require "../lib/doc.rkt") @doc-lib-setup -@title[#:style manual-doc-style]{Graph implementation} +@(define (comment . _) "") -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, 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. +@title[#:style manual-doc-style]{Graph library} @(table-of-contents) -@section{Notes on complex transform result types} +@; TODO: allow a mapping to return a new placeholder, in order to act as a +@; redirect. All references to the old placeholder will act as if they were to +@; the new placeholder. -We wish at one point to support complex result types for the transforms, instead -of only allowing a single node type. +@section{Introduction} -We have to impose a constraint: do not have a cycle inside the transform's -result that doesn't go through a node, since we break cycles by replacing nodes -with a promise. The safest way to satisfy that constraint is to enforce the -absence of loops at the type level. +This module provides a @tc[graph] macro which helps constructing immutable +graphs (using lambdas to defer potentially cyclic references). -We would then inline the called transform's results, breaking the cycles by -replacing nodes with a thunk that returns the desired node. That thunk will be -wrapped into a Promise that calls it, so that typed/racket's occurrence typing -is happy, but we don't rely on the memoization semantics. +@subsection{Example usage} -@subsection{Compile-time handling of complex transform result types} +We will start with a running example, which will help us both show the macro's +syntax, and see some of the key advantages offered by this graph library. -During macro-expansion, we generate procedures that process nodes found in -transforms' results, by inlining the results of called transforms. If we find a -@tc[transform/link-request] type in some place we don't know how to rewrite -(like a function type, for example), we throw an error. Similarly, if we -encounter a cycle in the type that does not go through a node type, we throw an -error. +@subsection{The graph's type} -These procedures will help generate code to make a facade node from the -incomplete one. When inlining results from called transforms, they will request -other incomplete nodes from the database. +Each node type in the graph is a variant's constructor, tagged with the node +name. For example, a graph representing a city and its inhabitants could use +these constructors: -@subsection{Two-step graph creation} +@chunk[ + [City [streets : (Listof Street)] [people : (Listof Person)] ] + [Street [sname : String] [houses : (Listof House)] ] + [House [owner : Person] [location : Street] ] + [Person [name : String] ]] -Writing a graph-generation macro that allows complex return types for transforms -seems difficult, and it would be easier to write a simple graph-generation -macro, that only accepts transforms with return a single node type. We could -build on top of that a more flexible macro, that would first generate a graph -where each transform's result is wrapped in an ad-hoc single-field node. Then, -we would automatically generate a second graph transformation that produces the -desired nodes from that graph. +Notice the cycle in the type: a street contains houses, which are located on the +same street. -Example: transform @tc[t1] takes a list of numbers as input, and produces a list -of either calls to transform @tc[t2] or nodes @tc[ni] as output. The @tc[t2] -transform generates a pair of nodes @tc[(ni [x Number])] and -@tc[(nj [y String])]. +@subsubsection{A seed from which to unravel the graph: the root parameters} -The user would describe the graph like this: +In order to build a graph with that type, we start from the root parameters. +Here, we will take a representation of the city as a list of +@tc[(street-name . person-name)] pairs, and will convert it to a more convenient +graph representation. Our single root parameter will thus be the whole list: -@chunk[ - (make-graph ([root (Listof (U ni (Pairof ni nj)))] - [ni [x Number]] - [nj [y String]]) - [(t1 [ln : (Listof Number)] : (Listof (U ni t2)) - (map (λ (x) (if (even? x) - (t2 x) - (ni x))) - ln))] - [(t2 [n : Number] : (Pairof ni nj) - (cons (ni n) (nj (format "~a" n))))])] +@chunk[ + '(["Amy" . "Ada Street"] + ["Jack" . "J Street"] + ["Anabella" . "Ada Street"])] -In the above, the result type of @tc[t1] has to be @tc[(Listof (U ni t2))] -instead of @tc[(Listof (U ni (Pairof ni nj)))], because otherwise we can't -easily automatically infer that @tc[(Pairof ni nj)] was actually @tc[t2], -without looking at the body of the transform. In a more advanced version, we -could substitute every @tc[result-type] found in another transform's -@tc[result-type] by @tc[(U result-type transform/link-request)], however that -would likely produce spurious cycles that do not go through a node, so it's -probably best to make things explicit, and let the user write @tc[U]. +We will then provide a mapping from the root parameter to the root node, in our +case @tc[City]. When processing the root parameter, one can call other mappings +that will create their corresponding nodes. -@chunk[ - (graph ([r-t1 [result (Listof (U ni t2))]] - [r-t2 [result (Pairof ni nj)]]) - [(t1 [ln : (Listof Number)] : r-t1 - (r-t1 (map (λ (x) (if (even? x) - (t2 x) - (ni x))) - ln)))] - [(t2 [n : Number] : r-t2 - (r-t2 (cons (ni n) - (nj (format "~a" n)))))])] +@subsubsection{Mapping the root parameters to the root node} -Then use this graph transform: +Here is the root mapping for our example. It maps over the list of names and +street names @tc[c], and calls for each element the @tc[m-street] and +@tc[m-person] mappings. -@chunk[ - (make-graph ([root [result (Listof (Pairof ni nj))]] - [ni [x Number]] - [nj [y String]]) - [(r-t1→root [t1 : r-t1]) : root - (root (map (λ (v) - (match v - [(? list?) (r-t2-result v)] - [(ni _) v])) - (r-t1-result t1)))])] +@; Would be nicer with (map (∘ (curry street c) car) c)), but that doesn't +@; typecheck (yet). +@chunk[ + [(m-city [c : (Listof (Pairof String String))]) + (City (remove-duplicates (map (curry m-street c) (cdrs c))) + (remove-duplicates (map m-person (cars c))))]] -@subsection{Many to one transforms} +@subsubsection{More mappings} -This example covers one to many transforms. What about many to one transforms? -The macro we are building allows generating graphs, but does not care about the -input. In the case were transforming a graph of @tc[house]s, @tc[street]s and a -@tc[city], and we want to condense all the @tc[house]s on one side of each -@tc[street] to a @tc[suburb], we would write a transform @tc[t1] for@tc[street] -which passes the whole list of @tc[house]s to a transform @tc[t2]. The @tc[t2] -transform would create a @tc[suburb] from those, without calling a transform for -each @tc[house]. +Next, we write the @tc[m-street] mapping, which takes a street name and the +whole city @tc[c] in list form, and creates a @tc[Street] node. -@subsection{Implicit rule names} +@chunk[ + [(m-street [c : (Listof (Pairof String String))] [s : String]) + (Street s (map (curry (curry m-house s) c) + (cars (filter (λ ([x : (Pairof String String)]) + (equal? (cdr x) s)) + c))))]] -In order to allow implicit rule names, when there's only one rule with the -desired result node, we can use the node's name as the transform name. We should -think about naming conflicts: when calling @tc[n], should it insert a link -request for the transform, or should it create an incomplete node? +The @tc[m-house] mapping defined below calls back the @tc[m-street] mapping, to +store for each house a reference to the containing street. Normally, this would +cause infinite recursion in an eager language, like @tc[typed/racket]. However, +the mappings aren't called directly, and instead, in the body of @tc[m-house], +@tc[m-street] is shadowed by a function which returns a placeholder. This allows +us to not worry about mutually recursive mappings: a mapping can be called any +number of times with the same data, it will actually only be run once. -@subsection[#:tag "graph|complex-transforms-return-type-conclusion"]{Conclusion} +The @tc[define-graph] macro will post-process the result of each mapping, and +replace the placeholders with promises for the the result of the mapping. The +promises are not available during graph construction, so there is no risk of +forcing one before it is available. -With this approach, we can write the graph creation macro with the guaranty -that the result of a transform always is exactly one node type. More complex -transform result types can be decomposed into to two passes. +We can now write the @tc[m-house] and @tc[m-person] mappings. -A downside is that we can't inspect the result of a call to another transform, -since it's not actually calling it, and we're only getting an opaque link -request back. We couldn't call the other transform anyway, because it could half -of the time return a value immediately, and half of the time call us back (with -the same arguments), causing an infinite loop. For that, we could declare some -#:helper transforms, that get called immediately (but if they run into an -infinite loop it's not our fault). +@chunk[ + [(m-house [s : String] + [c : (Listof (Pairof String String))] + [p : String]) + (House (m-person p) (m-street c s))]] -@section{Comparison with @racket[make-placeholder] and - @racket[make-reader-graph]} +@chunk[ + [(m-person [p : String]) + (Person p)]] -Comparison of this approach with @tc[make-placeholder] and -@tc[make-reader-graph]: +@subsubsection{Creating an instance of the graph} + +For now, we will supply directly the root arguments to the @tc[define-graph] +macro, as well as the node types and mappings. We can later curry the macro, so +that it first takes the node types and mappings, and produces a lambda taking +the root arguments as parameters. + +@chunk[ + (define-graph make-g ) + #;(define g (make-g )) + (define g1 (make-g )) + (define g g1)] + +@subsection{More details on the semantics} + +Let's take a second look at the root mapping: + +@chunk[ + [(m-city [c : (Listof (Pairof String String))]) + (City (remove-duplicates (map (curry m-street c) (cars c))) + (remove-duplicates (map m-person (cdrs c))))]] + +As this example shows, we can use @tc[m-street] as any other function, passing +it to @tc[curry], and calling @tc[remove-duplicates] on the results. Note that +each placeholder returned by @tc[m-street] will contain all information passed +to it, here a street name and @tc[c]. Two placeholders for @tc[m-street] will +therefore be @tc[equal?] if and only if all the arguments passed to +@tc[m-street] are @tc[equal?]. The placeholders also include a symbol specifying +which mapping was called, so two placeholders for two different mappings will +not be @tc[equal?], even if identical parameters were supplied. + +The node type allowing placeholders is derived from the ideal type given above. +Here, the type for @tc[Person] is @tc[[Person [name : String]]], so there are no +substitutions to make. Conversely, the type for @tc[City], originally expressed +as @tc[[(Listof Street) (Listof Person)]], will be rewritten as +@tc[[(Listof Street/placeholder-type) (Listof Person/placeholder-type)]]. + +The @tc[rewrite-type] module, which we use to derive types with placeholders +from the ideal ones, only handles a handful of the types offered by +@tc[typed/racket]. In particular, it does not handle recursive types described +with @tc[Rec] yet. + +@section{Implementation} + +In this section, we will describe how the @tc[define-graph] macro is +implemented. + +@subsection{The macro's syntax} + +We use a simple syntax for @tc[define-graph], and make it more flexible through +wrapper macros. + +@chunk[ + (define-graph name + [node … ] + …)] + +Where @tc[] is: + +@chunk[ + [field:id :colon field-type:expr]] + +And @tc[] is: + +@chunk[ + ((mapping:id [param:id :colon param-type:expr] …) + . mapping-body)] + +@subsection{The different types of a node} + +A single node name can refer to several types: @itemlist[ - @item{They don't guarantee at compile-time that you'll fill in all - placeholders. We could use @racket[make-placeholder] and - @racket[make-reader-graph] wrapped inside a macro that makes sure that all - placeholders are filled (same approach as we have).} - @item{I don't think you can iterate over all the nodes or over the nodes of a - specific type, and @racket[make-placeholder] isn't typed (yet) anyway I - guess).}] + @item{The @emph{ideal} type, expressed by the user, for example + @racket[[City (Listof Street) (Listof Person)]], it is never used as-is in + practice} + @item{The @emph{placeholder} type, type and constructor, which just store the + arguments for the mapping along with a tag indicating the node name} + @item{The @emph{incomplete} type, in which references to other node types are + allowed to be either actual (@racket[incomplete]) instances, or placeholders. + For example, @racket[[City (Listof (U Street Street/placeholder-type)) + (Listof (U Person Person/placeholder-type))]].} + @item{The @emph{with-indices} type, in which references to other node types + must be replaced by an index into the results list for the target node's + @racket[with-promises] type. For example, + @racket[[City (Listof (List 'Street/with-indices-tag2 Index)) + (Listof (List 'Person/with-indices-tag2 Index))]].} + @item{The @emph{with-promises} type, in which references to other node types + must be replaced by a @racket[Promise] for the target node's + @racket[with-promises] type. For example, + @racket[[City (Listof (Promise Street/with-promises-type)) + (Listof (Promise Person/with-promises-type))]].} + @item{The @emph{mapping function}, which takes some parameters and + returns a node (using the code provided by the user)}] -@section{Constructor} +We derive identifiers for these based on the @tc[node] name: -Here is an overview of the architecture of the graph constructor: +@;;;; +@chunk[ + (define/with-syntax ((root-param …) . _) #'((param …) …)) + (define/with-syntax ((root-param-type …) . _) #'((param-type …) …)) + + (define-temp-ids "~a/make-placeholder" (node …) #:first-base root) + (define-temp-ids "~a/placeholder-type" (node …)) + (define-temp-ids "~a/placeholder-tag" (node …)) + (define-temp-ids "~a/placeholder-queue" (node …)) + + (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/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/index-type" (node …)) + (define-temp-ids "~a/with-indices→with-promises" (node …) + #:first-base root) + + (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/mapping-function" (node …)) + + (define-temp-ids "~a/database" (node …) #:first-base root) + + (define-temp-ids "~a/value" ((field …) …))] -@itemlist[ - @item{We first save the parameter types in the old context, because we later - shadow the node names, and the parameters should refer to the old types. - Depending on how we write the rest, this might not be necessary though, since - it is possible we need to write @racket[(og node)] to refer to nodes types - from the old graph @racket[og].} - @item{We then define the node names as constructors for incomplete types — - which means that they can contain link requests for the results other - transforms} - @item{We define data structures representing link requests. Each link request - encapsulates a thunk that performs the transform's work when called, as well - as the name of the transform and its arguments, used to detect when we have - two identical link requests (which can be due to cycles in the resulting - graph, for example).} - @item{We then define the transforms as procedures that return a link request.}] +@subsection{Overview} -@chunk[ - (define-syntax/parse - (make-graph-constructor ([node (field:id field-type:expr) ...] ...) - [transform:id (param:id param-type:expr) ... - (~literal :) result-type:id - body ...] - ...) - - - - - - - #`(let () - - (let () - - - - - - make-graph-database)))] +The macro relies heavily on two sidekick modules: @tc[rewrite-type], and +@tc[fold-queue]. The former will allow us to derive from the ideal type of a +node the incomplete type and the with-promises type. It will also allow us to +search inside instances of incomplete nodes, in order to extract the +placehoders, and replace these parts with promises. The latter, @tc[fold-queue], +will be used to process all the pending placeholders, with the possibility to +enqueue more as new placeholders are discovered inside incomplete nodes. -@chunk[ - (define make-g (make-graph-constructor - ([ma (fav String) (faa ma) (fab mb)] - [mb (fbv String) (fba ma)]) - [transform-a (s String) : ma - (ma s - (transform-a s) - (transform-b "b"))] - [transform-b (s String) : mb - (mb s - (transform-a s))])) - (make-g "root-arg")] +When the graph constructor is called with the arguments for the root parameters, +it is equivalent to make and then resolve an initial placeholder. We will use a +function from the @tc[fold-queue] library to process the queues of pending +placeholders, starting with a queue containing only that root placeholder. +We will have one queue for each placeholder type.@note{It we had only one queue, + we would have only one collection of results, and would need a @racket[cast] + when extracting nodes from the collection of results.} The element types of the +queues will therefore be these placeholder types. -@subsection{Saving parameter types in old context} +@chunk[ + node/placeholder-type] -@chunk[ - (define/with-syntax ((param-type/old ...) ...) - (stx-map (λ (ps) - (with-syntax ([(t sps ...) ps]) - (format-temp-ids "~a/~a/memorized-type" #'t #'(sps ...)))) - #'((transform param ...) ...)))] +The return type for each queue will be the corresponding with-indices type. The +fold-queues function will therefore return a vector of with-indices nodes for +each node type. -@chunk[ - (define-type param-type/old param-type) - ... - ...] +@chunk[ + node/with-indices-type] -@subsection{Incomplete nodes} -When a transform returns an object, it is incomplete (it potentially contains -link requests instead of actual references to the nodes). +@; Problem: how do we ensure we return the right type for the root? +@; How do we avoid casts when doing look-ups? +@; We need several queues, handled in parallel, with distinct element types. +@; * Several result aggregators, one for each type, so we don't have to cast +@; * Several queues, so that we can make sure the root node is of the expected +@; type. -We prepare some template variables. The first is the name of the tagged variant -representing an incomplete node: +@; TODO: clarity. +@; The @tc[fold-queues] function allows us to associate each element with a tag, +@; so that, inside the processing function and outside, we can refer to an +@; element using this tag, which can be more lightweight than keeping a copy of +@; the element. +@; +@; We will tag our elements with an @tc[Index], which prevents memory leakage: +@; if we kept references to the original data added to the queue, a graph's +@; representation would hold references to its input, which is not the case when +@; using simple integers to refer to other nodes, instead of using the input for +@; these nodes. Also, it makes lookups in the database much faster, as we will +@; be able to use an array instead of a hash table. -@chunk[ - (define/with-syntax (node/incomplete ...) - (format-temp-ids "~a/incomplete" #'(node ...)))] +@subsection{The queues of placeholders} -Then, we build a reverse map, which from a node type obtains all the transforms -returning that node type. More specifically, we are interested in the -transform's link request type. +The fold-queues macro takes a root element, in our case the root placeholder, +which it will insert into the first queue. The next clauses are the queue +handlers, which look like function definitions of the form +@tc[(queue-name [element : element-type] Δ-queues enqueue) : result-type]. The +@tc[enqueue] argument is a function used to enqueue elements and get a tag in +return, which can later be used to retrieve the processed element. -@chunk[ - (define/with-syntax ((node/link-request-types ...) ...) - (for/list ([x (in-syntax #'(node ...))]) - (multiassoc-syntax x - #'([result-type . transform/link-request] ...))))] +Since the @tc[enqueue] function is pure, it takes a parameter of the same type +as @tc[Δ-queues] representing the already-enqueued elements, and returns a +modified copy, in addition to the tag. The queue's processing body should return +two values: the result of processing the element, and the latest version of +@tc[Δ-queues], which stores the new elements to be added to the queue. -The third template variable we define maps transforms to the incomplete type for -their returned node. +@chunk[ + (fold-queues + [(node/placeholder-queue [e : ] + [Δ-queues : Δ-Queues] + enqueue) + : + ] + ...)] -@chunk[ - (define/with-syntax (transform/result-node/incomplete ...) - (for/list ([x (in-syntax #'(result-type ...))]) - (assoc-syntax x #'([node . node/incomplete] ...))))] +@subsection{Making placeholders for nodes} -@CHUNK[ - (define-type node (U node/link-request-types ...) - #:omit-define-syntaxes) - ... - (define-tagged node/incomplete [field field-type] ...) - ... - (define-multi-id node - #:match-expander-id node/incomplete - #:call-id node/incomplete) - ...] +We start creating the root placeholder which we provide to @tc[fold-queues]. -@subsection{Link requests for nodes} +@chunk[ + (root/make-placeholder root-param …)] -When a transform wants to produce a reference to the result of another transform -of some data, it generates instead a link request, which encapsulates the -desired transform and arguments, without actually performing it. +To make the placeholder, we will need a @tc[node/make-placeholder] function for +each @tc[node]. We first define the type of each placeholder (a list of +arguments, tagged with the @tc[node]'s name): -@chunk[ - (define/with-syntax (transform/link-request ...) - (format-temp-ids "~a/link-request" #'(transform ...)))] +@; TODO: maybe replace node types with placeholder types -Due to an issue with @tc[typed/racket] (@tc[struct]s aren't properly declared -inside a @tc[let]), we need to pre-declare the @tc[transform/link-request] -@tc[struct]. Since the call to make-graph could itself be inside a @tc[let], we -need to pre-declare it in this file, instead of declaring it at the top of the -macro. +@chunk[ + (define-type node/placeholder-type + (List 'node/placeholder-tag + param-type …))] -We're making the structure transparent for easier debugging, but at the time of -writing this, it needs not be. +@; TODO: just use (variant [mapping param-type ...] ...) -@chunk[ - (struct (TKey) - transform/link-request-pre-declared - ([key : TKey]) - #:transparent)] +Then we define the @tc[node/make-placeholder] function: -@chunk[ - (define-type transform/link-request - (transform/link-request-pre-declared - (List 'transform - param-type/old ...))) - ...] +@chunk[ + (: node/make-placeholder (→ param-type … node/placeholder-type)) + (define (node/make-placeholder param …) + (list 'node/placeholder-tag param …))] -@subsection{Transforms} +@subsection{Making with-indices nodes} -@chunk[ - (define/with-syntax (transform/link-request→incomplete ...) - (format-temp-ids "~a/link-request→incomplete" #'(transform ...)))] +We derive the @tc[with-indices] type from each @emph{ideal} node type using the +@tc[tmpl-replace-in-type] template metafunction from the rewrite-type library. +We replace all occurrences of a @tc[node] name with an @tc[Index], which +indicates at which index in the queue's results the successor can be found. -@chunk[ - (begin - (: transform/link-request→incomplete - (→ param-type/old ... transform/result-node/incomplete)) - (define (transform/link-request→incomplete param ...) - body ...)) - ...] +@; TODO: use a type-expander here, instead of a template metafunction. -@chunk[ - (begin - (: transform - (→ param-type/old ... transform/link-request)) - (define (transform param ...) - ((inst transform/link-request-pre-declared - (List 'transform - param-type/old ...)) - (list 'transform param ...)))) - ...] +@CHUNK[ + (define-type node/index-type (List 'node/with-indices-tag2 Index)) + + (define-type node/with-indices-type + (List 'node/with-indices-tag …)) + + (: node/make-with-indices (→ … + node/with-indices-type)) + (define (node/make-with-indices field …) + (list 'node/with-indices-tag field …))] -@section{Queue} +@CHUNK[ + (tmpl-replace-in-type field-type [node node/index-type] …)] -@chunk[ - (define/with-syntax (root-transform . _) #'(transform ...)) - (define/with-syntax ((root-transform/param-type ...) . _) - #'((param-type ...) ...)) - (define/with-syntax ((root-transform/param ...) . _) - #'((param ...) ...)) - (define/with-syntax (transform/transformed ...) - (format-temp-ids "~a/transformed" #'(transform ...))) - (define/with-syntax (root-transform/link-request . _) - #'(transform/link-request ...)) - (define/with-syntax recursive-call - #'(process-queue pending-requests - processed-requests - transform/transformed ...)) - (define/with-syntax (node/extract-link-requests ...) - (format-temp-ids "~a/extract-link-requests" #'(node ...))) - - - ] +@subsection{Making with-promises nodes} -To build the graph database, we take the parameters for the root transform, and -return lists incomplete nodes (one for each transform). +We derive the @tc[with-promises] type from each @emph{ideal} node type using +the @tc[tmpl-replace-in-type] template metafunction from the rewrite-type +library. We replace all occurrences of a @tc[node] name with a @tc[Promise] for +that node's @tc[with-promises] type. -The parameters for the root transform, addition to the transform's name, form -the first link request. To fulfil this link request and the ones found later, -we call the desired transform which returns an incomplete node. We extract any -link requests found in that incomplete node, and queue them. The incomplete node -itself is added to the appropriate list, to be returned once the queue has been -fully processed. +@; TODO: use a type-expander here, instead of a template metafunction. -@CHUNK[ - (: make-graph-database - (→ root-transform/param-type ... - (List (Listof transform/result-node/incomplete) ...)))] +@CHUNK[ + + (define-type node/with-promises-type + (tagged node/with-promises-tag + [field : ] …)) + + (: node/make-with-promises (→ … + node/with-promises-type)) + (define (node/make-with-promises field/value …) + (tagged node/with-promises-tag + [field : field/value] + …))] -The @tc[make-graph-database] function consists mainly in the process-queue -function, which takes a queue for each transform, and a list of -already-processed incomplete nodes for each transform, and returns these lists, -once all queues are empty. +@CHUNK[ + (tmpl-replace-in-type field-type + [node (Promise node/with-promises-type)] …)] -@CHUNK[ - (define (make-graph-database root-transform/param ...) - (: process-queue (→ (Setof (U transform/link-request ...)) - (Setof (U transform/link-request ...)) - (Listof transform/result-node/incomplete) - ... - (List (Listof transform/result-node/incomplete) - ...))) - (define (process-queue pending-requests - processed-requests - transform/transformed - ...) - ;; TODO: Can probably be moved out. - ) +@subsection{Making incomplete nodes} + +We derive the @tc[incomplete] type from each @emph{ideal} node type using +the @tc[tmpl-replace-in-type] template metafunction from the rewrite-type +library. We replace all occurrences of a @tc[node] name with its +@tc[placeholder] type. + +@; TODO: use a type-expander here, instead of a template metafunction. + +@CHUNK[ + (define-type node/incomplete-type + (List 'node/incomplete-tag …)) + + (: node/make-incomplete (→ … + node/incomplete-type)) + (define (node/make-incomplete field …) + (list 'node/incomplete-tag field …))] + +@CHUNK[ + (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 +@chunk[ + (λ ([p : node/placeholder-type] [Δ-acc : Δ-Queues]) + : (values (List 'node/with-indices-tag2 Index) Δ-Queues) + (% index new-Δ-acc = (enqueue 'node/placeholder-queue p Δ-acc) + (values (list 'node/with-indices-tag2 index) + new-Δ-acc)))] + +@chunk[ + [node/placeholder-type + (List 'node/with-indices-tag2 Index) + (λ (x) (and (pair? x) + (eq? (car x) 'node/placeholder-tag))) + ]] + +@subsubsection{Processing the placeholders} + +@; TODO: also allow returning a placeholder (which means we should then +@; process that placeholder in turn). The placeholder should return the +@; same node type, but can use a different mapping? +@; Or maybe we can do this from the ouside, using a wrapper macro? + +@; TODO: we don't need that many let etc., use % instead once everything works. +@CHUNK[ + (let ([mapping-result (apply node/mapping-function (cdr e))]) + (let ([f (tmpl-fold-instance (List …) + Δ-Queues + …)]) + (let-values ([(r new-Δ-queues) (f (cdr mapping-result) Δ-queues)]) + (values (cons 'node/with-indices-tag r) + new-Δ-queues))))] + +Where @tc[] is the @tc[field-type] in which node types +are replaced by placeholder types: + +@chunk[ + (tmpl-replace-in-type field-type + [node node/placeholder-type] …)] + +@subsection{The mapping functions} + +We define the mapping functions as they are described by the user, with an +important change: Instead of returning an @emph{ideal} node type, we expect them +to return an @emph{incomplete} node type. + +@chunk[ + (: node/mapping-function (→ param-type … node/incomplete-type)) + (define node/mapping-function + (let ([mapping node/make-placeholder] + … + [node node/make-incomplete] + …) + (λ ([param : param-type] …) : node/incomplete-type + . mapping-body)))] + +@subsection{Returning a with-promises nodes} + +We will return a with-promises version of the root node, which contains promises +for its successors. The user can then force one of these to obtain the +with-promises version of the desired successor. + +@; TODO: put a diagram here, or an example at least + +This use of promises is safe, since their resolution depends only on the vectors +returned by fold-queues, which are already fully computed when we create the +root with-promises node. We therefore have no risk of forcing a promise that +can't be resolved, or that would depend on itself, causing an infinite loop. + +@subsubsection{Why use promises?} + +We use promises because we would like to only use immutable data structures. +Resolving the links in the graph would require mutating the nodes, so instead, +when extracting the @emph{placeholders} from an @emph{incomplete} node, we +produce a @emph{with-indices} node, which, instead of direct references to the +successors, just stores a tag and index. Later, the successors are processed, +and stored at the corresponding index in the queue for that tag. + +We then wrap each tagged index with a lambda, which also holds a reference to +the vectors returned by fold-queue, which containin all the with-indices nodes. +When calling the lambda, it extracts the with-indices node for that tag and +index, further replaces the tagged indices within, and returns a brand new +with-promises node. + +We could leave it as that, having the with-promises nodes contain lambdas +instead of actual references to their successors. However, when an immutable +function (like one of these lambdas) is called twice with the same arguments (in +this case none), @tc[typed/racket]'s occurrence typing currently does not infer +that the result will always be the same. This means that pattern-matching using +the @tc[match] macro won't work properly, for example. We therefore wrap these +functions into promises. The occcurrence typing mechanism in @tc[typed/racket] +knows that a promise will always return the same value when forced multiple +times. By default, promises use mutable data structures under the hood, to cache +their result, but we do not rely on that. We could use @tc[delay/name], which +doesn't cache the return value, but it was removed from @tc[typed/racket] +because @hyperlink["https://github.com/racket/typed-racket/issues/159"]{it + caused type safety problems}. + +@subsubsection{Creating with-promises nodes from with-indices ones} + +@chunk[ + [node/index-type + (Promise node/with-promises-type) + (λ (x) (and (pair? x) + (eq? (car x) 'node/with-indices-tag2))) + (λ ([tagged-index : node/index-type] [acc : Void]) + : (values (Promise node/with-promises-type) Void) + (values acc))]] + +TODO: check what we are closing over in that promise. +I think we are closing over the successor-with-index (but not its whole +database), as well as everything that the with-indices→with-promises function +closes over. + +@chunk[ + (let ([successor-with-index (vector-ref node/database + (cadr tagged-index))]) + (delay (node/with-indices→with-promises successor-with-index)))] + +@chunk[ + (: node/with-indices→with-promises (→ node/with-indices-type + node/with-promises-type)) + (define (node/with-indices→with-promises n) + (define f (tmpl-fold-instance (List …) + Void + …)) + (apply node/make-with-promises (first-value (f (cdr n) (void)))))] + +Where @tc[] is the @tc[field-type] in which node types +are replaced by tagged indices: + +@chunk[ + (tmpl-replace-in-type field-type [node node/index-type] …)] + +@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +@comment[#| + @subsection{Converting incomplete nodes to with-promises ones} + + @chunk[ + [node/incomplete-type + node/with-promises-type + (λ (x) (and (pair? x) (eq? (car x) 'node/incomplete-tag))) + (λ ([x : node/incomplete-type] [acc : Void]) + )]] + + @chunk[ + [mapping/placeholder-type + (tmpl-replace-in-type result-type [node node/with-promises-type] …) + (λ (x) (and (pair? x) (eq? (car x) 'mapping/placeholder-tag))) + (λ ([x : mapping/placeholder-type] [acc : Void]) + )]] + + @; TODO: this would be much simpler if we forced having only one mapping per + @; node, and extended that with a macro. + + @chunk[ + (define/with-syntax ((node/compatible-mappings ...) ...) + (for/list ([x (in-syntax #'(node ...))]) + (multiassoc-syntax + x + #'([result-type . mapping] + …))))] + + @chunk[ + (error (~a "Not implemented yet " x))] + + @chunk[ + (% index new-Δ-queues = (enqueue 'mapping/placeholder-tag x Δ-queues) + (list 'mapping/placeholder-tag index) + (error (~a "Not implemented yet " x)))] + |#] + +@section{Putting it all together} + +@chunk[ + (define-syntax/parse + + #|((λ (x) (pretty-write (syntax->datum x)) x)|# + (template + ;(let () + (begin + (begin ) … + (begin ) … + (begin ) … + (begin ) … + (begin ) … + (begin ) … + + (: name (→ root-param-type … (Promise root/with-promises-type))) + (define (name root-param …) + (match-let ([(list node/database …) ]) + (begin ) … + (let ([root/with-promises (root/with-indices→with-promises + (vector-ref root/database 0))]) + (delay root/with-promises)))))))] + +@chunk[ + (module main typed/racket + (require (for-syntax syntax/parse + racket/syntax + syntax/stx + syntax/parse/experimental/template + racket/sequence + "rewrite-type.lp2.rkt" + "../lib/low-untyped.rkt") + "fold-queues.lp2.rkt" + "rewrite-type.lp2.rkt" + "../lib/low.rkt" + "structure.lp2.rkt" + "variant.lp2.rkt" + "../type-expander/type-expander.lp2.rkt") - )] - -The @tc[process-queue] function is initially called with empty lists for all -queues and all result lists, except for the root transform's queue, which -contains the initial link request. - -@CHUNK[ - (process-queue (set (root-transform root-transform/param ...)) - (set) - (begin 'transform/transformed '()) - ...)] - -Process-queue is a standard queue handler using sets. - -@CHUNK[ - (if (set-empty? pending-requests) - (list transform/transformed ...) - (let* ([request (set-first pending-requests)] - [pending-requests (set-rest pending-requests)] - [processed-requests (set-add processed-requests request)] - [tag (car (transform/link-request-pre-declared-key request))]) - ))] - -To process each link request, we first match on its type, and once we found it, -we call the result thunk, extract any link requests contained within, and add -those to the queue. - -@CHUNK[ - (cond - [(eq? tag 'transform) - (let* ([transformed - : transform/result-node/incomplete - (apply transform/link-request→incomplete - (cdr (transform/link-request-pre-declared-key - request)))] - [transform/transformed - (cons transformed transform/transformed)] - [extracted - (list->set - (transform/result-node/extract-link-requests transformed))] - [pending-requests - (set-union pending-requests - (set-subtract extracted processed-requests))]) - recursive-call)] - ...)] - -@subsection[#:tag "graph|TODO3"]{TODO} - -We need to traverse the @tc[transformed] node (which is an incomplete node), -and find the link requests within. These link requests will be added to the -corresponding @tc[pending-requests] queue. Below is the body of a for-syntax -function that transforms a type with link-requests into the @tc[match] patterns -that will be used at run-time to traverse the incomplete node. In most cases, -there is only one pattern, but the @tc[U] requires one for each possibility. - -When we encounter a link request, we prepend it to the corresponding queue. -For the type @tc[(List Number n/link-request)], the function will look like -this: - -@chunk[ - (match transformed - [(list a b) - (match a [a2 a2]) - (match b [(and t - (transform/link-request-pre-declared - (cons 'transform1 _))) - (set! pending-requests - (cons t pending-requests))])])] - -@subsubsection{Match clauses} - -We first transform the type into the different match clauses. For that, we -define the @tc[fold-type-clauses] function, which takes the identifier to -destructure at run-time, and its type. The function returns a list of clauses. - -@chunk[ - (define (fold-type-clauses val t) - (syntax-parse t - ))] - -When a link request is found in the type, we produce the corresponding match -clause, which body prepends the request to the queue of pending requests. For -now we use @racket[set!] to prepend the request, but it would be cleaner to use -recursion. We wouldn't even need to flatten the pending-requests list, because -it could be a tree instead of a flat list, since we only need to add to it and -later pop elements. - -TODO: we currently ignore potential hiding of identifiers due to type variables -bound by Rec, for example. This is a case where having a fold-type function -provided by the type-expander library would be interesting. - -@CHUNK[ - [x:id - #:when (ormap (curry free-identifier=? #'x) - (syntax->list #'(node/incomplete ...))) - (define/with-syntax (this-field-type ...) - (assoc-syntax #'x #'((node/incomplete field-type ...) ...))) - - (define/with-syntax (tmp ...) - (generate-temporaries #'(this-field-type ...))) - #`([(x tmp ...) - (append #,@(stx-map fold-type - #'(tmp ...) - #'(this-field-type ...)))])]] - -@CHUNK[ - [x:id - #:when (ormap (curry free-identifier=? #'x) - (syntax->list #'(node ...))) - #`([(and t (transform/link-request-pre-declared (cons 'transform _))) - (cons (ann t transform/link-request) '())] - ...)]] - -We handle fixed-length lists by calling @tc[fold-type] on each element type. - -@CHUNK[ - [((~literal List) a ...) - (define/with-syntax (tmp ...) (generate-temporaries #'(a ...))) - #`([(list tmp ...) - (append #,@(stx-map fold-type #'(tmp ...) #'(a ...)))])]] - -We iterate variable-length lists at run-time. - -@CHUNK[ - [((~literal Listof) a) - #`([(list tmp (... ...)) - (append-map (λ (tmp1) #,(fold-type #'tmp1 #'a)) - tmp)])]] - -Pairs and vectors are handled similarly: - -@CHUNK[ - [((~literal Pairof) a b) - #`([(cons tmpa tmpb) - (list #,(fold-type #'tmpa #'a) - #,(fold-type #'tmpb #'b))])]] - -@CHUNK[ - [((~literal Vectorof) a) - #'([(vector tmp (... ...)) - (append-map (λ (tmp1) #,(fold-type #'tmp1 #'a)) - tmp)])]] - -For unions, we return several clauses, obtained via a recursive call to -@tc[fold-type-clauses]. - -@CHUNK[ - [((~literal U) a ...) - #`(#,@(stx-map fold-type-clauses val #'(a ...)))]] - -We handle other cases by leaving them as-is, but we still check that they don't -contain a reference to a node type, because we would otherwise leave the -link-request there. - -And the fourth maps transforms to the link-requests extraction procedure for -their returned node. - -@chunk[ - (define/with-syntax (transform/result-node/extract-link-requests ...) - (for/list ([x (in-syntax #'(result-type ...))]) - (assoc-syntax x #'([node . node/extract-link-requests] ...))))] - -The last case is when we encounter an unknown type. We assume that it does not -contain any link-requests and therefore return an empty list. - -@CHUNK[ - [x:id - #`([_ '()])]] - -@subsubsection{Folding the type: extracting link requests} - -The for-syntax function @tc[fold-type] generates code that uses @tc[match] to -extract the @tc[link-request]s from an incomplete node (or part of it) with type -@tc[t]. The match clauses are those returned by @tc[fold-type-clauses] defined -above. - -@CHUNK[ - (define (fold-type val t) - #`(begin - (match #,val #,@(fold-type-clauses val t))))] - -@subsubsection{Fold function for each incomplete node} - -For each node type, we wish to declare a function that extracts link requests -from the incomplete type. We should work on the expanded type. - -@chunk[ - (define-template-metafunction (fold-type-tmpl stx) - (syntax-case stx () [(_ val t) (fold-type #'val #'t)]))] -@CHUNK[ - #,@(for/list ([name (in-syntax #'(node/extract-link-requests ...))] - [val-type (in-syntax #'(node/incomplete ...))] - [field-types (in-syntax #'((field-type ...) ...))]) - #`(define (#,name [val : #,val-type]) - : (Listof (U transform/link-request ...)) - #,(fold-type #'val val-type)))] - -@subsubsection[#:tag "graph|TODO1"]{TODO} - -Later, we will replace link requests with thunks returning the desired node, -wrapped in a promise in order to please occurrence typing. Below is the body of -the for-syntax function that transforms a type with link-requests into a type -with actual nodes. It's probably not useful, because we obtain the same result -with scopes. - -@CHUNK[ - [x:id - #:when - (ormap (curry free-identifier=? #'x) - (syntax->list #'(node/link-request ...))) - #`(Promise (→ #,(assoc-syntax #'x #'((node/link-request . node) ...))))] - [((~literal List) a ...) #`(List #,@(stx-map fold-type #'(a ...)))] - [((~literal Listof) a) #`(Listof #,@(stx-map fold-type #'(a ...)))] - [((~literal Pairof) a b) #`(Pairof #,(fold-type #'a) #,(fold-type #'b))] - [((~literal Vectorof) a) #'(Vectorof #,(fold-type #'a))] - [((~literal U) a ...) #'(U #,(stx-map fold-type #'(a ...)))]] - -@section{@racket[incomplete] type-expander} - -We define a @tc[type-expander] @tc[(incomplete n)] that returns the incomplete -node type for the node type @tc[n]. This type-expander allows the user to refer -to the incomplete type of the node in the body of a transform, if annotations -are needed for a value containing such a node. - -@chunk[ - (define-type-expander (incomplete stx) - (syntax-case stx () - [(_ n) - (raise-syntax-error - 'incomplete - (format "Type doesn't have an incomplete counterpart: ~a" - (syntax->datum #'n)) - #'n)]))] - -@chunk[ - (define-type-expander (outer-incomplete stx) - (syntax-case stx () [(_ n) #'(incomplete n)]))] - -@chunk[ - (let () - - (let () - (define-type node - (tagged node [field (Promise field-type)] ...)) - ... - - (define-type node/incomplete - ;; TODO: substitute link-requests here - (tagged node [field (Promise field-type)] ...)) - - (define-type-expander (incomplete stx) - (syntax-parse stx () - [(_ (~litral node)) #'node/incomplete] - [_ #'(outer-incomplete n)])) - ))] - -@section{Transforming @racket[incomplete] nodes into complete ones} - -@subsection{Initial version} - -We will start with a very simple traversal function, that will just substitute -link requests immediately in the fields of a node. - -@chunk[ - (define (substitute-link-requests v) - (match v - [(node/incomplete field ...) - (node ...)] - ...))] - -@chunk[ - (match field - [(transform/link-request key _) (transform/key→promise key)] ;; TODO - ...)] - -@chunk[ - ] - -@subsection{More complex attempt} - -We know for sure that all references to future nodes are actually incomplete -ones, but we have no guarantee about the contents of the fields of a node. Since -they may contain a mix of link requests and primitives (via a @tc[U] type for -example), and may contain lists of nodes etc. we need to traverse them at -run-time, in order to find and replace references to link requests. - -However, if we were to write this as a simple recursive function, we wouldn't be -able to express its type without knowing anything about the node's type: - -@chunk[ - (case→ (→ node/link-request node) ... - (→ (Pairof may-contain-link-request - may-contain-link-request) - (Pairof doesnt-contain-link-request - doesnt-contain-link-request)))] - -Writing the @tc[may-contain-link-request] and @tc[doesnt-contain-link-request] -as functions, while expressing the contraint that the output is the same type as -the input — except for the link requests that turned into nodes, would be -impossible in typed/racket. I suppose that with GADTs one could write such a -type. - -Instead, we will, during macro-expansion, traverse the type, and generate -conversion procedures accordingly. - -@chunk[ - [(~literal node/link-request) #''link-request] - ... - [((~literal List) a ...) #'(List #,@(stx-map fold-type #'(a ...)))] - [((~literal Listof) a) #''Listof] - [((~literal Pairof) a) #''Pairof] - [((~literal Vectorof) a) #''Vectorof] - [((~literal U) a ...) #''U]] - -@chunk[ - (→ (List a ...) (List replaced-a ...))] - -@chunk[ - [(list? v) (map traverse-list v)] - [(pair? v) (cons (traverse-list (car v)) - (traverse-list (cdr v)))] - [(vector? v) ]] - -@subsection{Unions} - -Unions are difficult to handle: At one extreme, we confuse two different types -like @tc[(Listof Number)] and @tc[(Listof String)], by using just the @tc[list?] -predicate. On the other end of the spectrum, we try to distinguish them with -@tc[typed/racket]'s @tc[make-predicate], which doesn't work in all cases. - -Handling this in the best way possible is out of the scope of this project, so -we will just add special cases as-needed. - -@subsection{Unhandled} - -We currently don't handle structure types, prefab structures, hash tables, -syntax objects and lots of other types. - -On the other hand, we can't handle fixed-length @tc[(Vector ...)] types, because -occurrence typing currently can't track which case we are in when we check the -length with @tc[(vector-length constant)]. We also can't handle functions, for -hopefully obvious reasons. - -@; TODO: insert a link to the type-expander document in the paragraph below. - -We run into a problem though with types declared via define-type without -informing the type-expander. The type-expander handles these by expanding just -their arguments, and leaving the type untouched, but we can't ignore them in our -case. - -For all these other cases, we'll just check that they don't contain any -reference to a link-request type. - -@chunk[ - [other - (fold-check-no-link-requests #'other) - #'other]] - -The checker below is approximate, and is just meant to catch the error as soon -as possible, and we include a fall-back case for anything we couldn't handle -properly. If we let a link-request slip, it should be caught by the type -checker, unless it is absorbed by a larger type, like in -@tc[(U Any link-request)], in which case it doesn't matter. - -@chunk[ - (define (fold-check-no-link-requests stx) - (syntax-parse stx - [(~and whole (~or (~literal node/link-request) ...)) - (raise-syntax-error - 'graph - "Found a link request buried somewhere I can't access" - whole)] - [(~and whole (t ...)) - (stx-map fold-check-no-link-requests #'(t ...))] - [whole whole]))] - -@section[#:tag "graph|TODO2"]{TODO} - -@chunk[ - (define (multiassoc-syntax query alist) - (map stx-cdr - (filter (λ (xy) (free-identifier=? query (stx-car xy))) - (syntax->list alist)))) - (define (assoc-syntax query alist) - (let ([res (assoc query (map syntax-e (syntax->list alist)) - free-identifier=?)]) - (unless res (raise-syntax-error '? (format "Can't find ~a in ~a" - query - alist))) - (cdr res)))] - -@CHUNK[ - ;; The actual traversal code: - ;; TODO: write a tail-recursive version, it's cleaner than using set!. - (: make-graph-database - (→ root-transform.param.type ... - (case→ (→ 'node.name (Listof (Pairof Any node.incomplete))) - ...))) - (define (make-graph-database root-transform.param.name ...) - (let ([pending : (Listof (U node.link-request ...)) - (list (cons (list 'root-transform.name - root-transform.param.name ...) - (λ () (root-transform.function - root-transform.param.name ...))))] - [all-transformed : (Listof (Pairof Symbol Any)) '()] - ;; the key is actually the second element in a - ;; link-request-???, but should be just a number like in - ;; the C# version. - [node.transformed : (Listof (Pairof Any node.incomplete)) '()] - ...) - (do : (case→ (→ 'node.name (Listof (Pairof Any node.incomplete))) - ...) - () - [(null? pending) - (ann (λ (selector) - (cond [(eq? selector 'node.name) node.transformed] ...)) - (case→ (→ 'node.name (Listof (Pairof Any node.incomplete))) - ...))] - (let ((request (car pending))) - ;; Must be immediately after the (let (...), because we cons to - ;; that list in the block below. - (set! pending (cdr pending)) - ;; Skip already-transformed link requests. TODO: map a number - ;; for each. - (unless (member (car request) all-transformed) - ;; Call the lambda-part of the request. - (let ([transformed ((cdr request))]) - (cond - [(eq? (car transformed) 'node.name) - (set! pending - (list* ((cdr transformed) - 'node/field-filter-out-primitives/name) - ... - pending)) - (set! all-transformed (cons (car request) - all-transformed)) - (set! node.transformed - (cons (cons (car request) (cdr transformed)) - node.transformed))] - ... - ;; Make sure all cases are treated, at compile-time. - [else (typecheck-fail #'#,stx - "incomplete coverage")])))))))] - -@section{Tests} - -@chunk[ - (values)] - -@section{Conclusion} + ;(begin-for-syntax + ;) + + (provide define-graph) + )] + +In @tc[module-test], we have to require @tc[type-expander] because it provides a +@tc[:] macro which is a different identifier than the one from typed/racket, +therefore the @tc[:] bound in the @tc[graph] macro with @tc[:colon] would +not match the one from @tc[typed/racket] + +@chunk[ + (module* test typed/racket + (require (submod "..") + "fold-queues.lp2.rkt"; DEBUG + "rewrite-type.lp2.rkt"; DEBUG + "../lib/low.rkt"; DEBUG + "structure.lp2.rkt"; DEBUG + "variant.lp2.rkt"; DEBUG + "../type-expander/type-expander.lp2.rkt" + typed/rackunit) + + (provide g) + )] + +The whole file, finally: @chunk[<*> (begin - (module main typed/racket - (require (for-syntax racket/sequence - ;; in-syntax on older versions - ;;;unstable/sequence - syntax/parse - syntax/parse/experimental/template - racket/syntax - racket/function - syntax/stx - racket/pretty - "../lib/low-untyped.rkt" - "../lib/untyped.rkt") - (prefix-in DEBUG-tr: typed/racket) - syntax/parse - "../lib/low.rkt" - "structure.lp2.rkt" - "variant.lp2.rkt" - "../type-expander/multi-id.lp2.rkt" - "../type-expander/type-expander.lp2.rkt") - (provide make-graph-constructor - #|graph|#) - - (begin-for-syntax - ) - - - - - #||#) + (require 'main) (provide (all-from-out 'main)) - (module* test typed/racket - (require (submod "..") - "../type-expander/type-expander.lp2.rkt" - "../lib/test-framework.rkt") - - ;; Debug - - (require syntax/parse - "../lib/low.rkt" - "structure.lp2.rkt" - "variant.lp2.rkt" - "../type-expander/multi-id.lp2.rkt" - "../type-expander/type-expander.lp2.rkt") - ;; - - - ))] + )] diff --git a/graph-lib/graph/graph3.lp2.rkt b/graph-lib/graph/graph3.lp2.rkt deleted file mode 100644 index 6e4e19b5..00000000 --- a/graph-lib/graph/graph3.lp2.rkt +++ /dev/null @@ -1,655 +0,0 @@ -#lang debug scribble/lp2 -@(require "../lib/doc.rkt") -@doc-lib-setup - -@(define (comment . _) "") - -@title[#:style manual-doc-style]{Graph library} - -@(table-of-contents) - -@; TODO: allow a mapping to return a new placeholder, in order to act as a -@; redirect. All references to the old placeholder will act as if they were to -@; the new placeholder. - -@section{Introduction} - -This module provides a @tc[graph] macro which helps constructing immutable -graphs (using lambdas to defer potentially cyclic references). - -@subsection{Example usage} - -We will start with a running example, which will help us both show the macro's -syntax, and see some of the key advantages offered by this graph library. - -@subsection{The graph's type} - -Each node type in the graph is a variant's constructor, tagged with the node -name. For example, a graph representing a city and its inhabitants could use -these constructors: - -@chunk[ - [City [streets : (Listof Street)] [people : (Listof Person)] ] - [Street [sname : String] [houses : (Listof House)] ] - [House [owner : Person] [location : Street] ] - [Person [name : String] ]] - -Notice the cycle in the type: a street contains houses, which are located on the -same street. - -@subsubsection{A seed from which to unravel the graph: the root parameters} - -In order to build a graph with that type, we start from the root parameters. -Here, we will take a representation of the city as a list of -@tc[(street-name . person-name)] pairs, and will convert it to a more convenient -graph representation. Our single root parameter will thus be the whole list: - -@chunk[ - '(["Amy" . "Ada Street"] - ["Jack" . "J Street"] - ["Anabella" . "Ada Street"])] - -We will then provide a mapping from the root parameter to the root node, in our -case @tc[City]. When processing the root parameter, one can call other mappings -that will create their corresponding nodes. - -@subsubsection{Mapping the root parameters to the root node} - -Here is the root mapping for our example. It maps over the list of names and -street names @tc[c], and calls for each element the @tc[m-street] and -@tc[m-person] mappings. - -@; Would be nicer with (map (∘ (curry street c) car) c)), but that doesn't -@; typecheck (yet). -@chunk[ - [(m-city [c : (Listof (Pairof String String))]) - (City (remove-duplicates (map (curry m-street c) (cdrs c))) - (remove-duplicates (map m-person (cars c))))]] - -@subsubsection{More mappings} - -Next, we write the @tc[m-street] mapping, which takes a street name and the -whole city @tc[c] in list form, and creates a @tc[Street] node. - -@chunk[ - [(m-street [c : (Listof (Pairof String String))] [s : String]) - (Street s (map (curry (curry m-house s) c) - (cars (filter (λ ([x : (Pairof String String)]) - (equal? (cdr x) s)) - c))))]] - -The @tc[m-house] mapping defined below calls back the @tc[m-street] mapping, to -store for each house a reference to the containing street. Normally, this would -cause infinite recursion in an eager language, like @tc[typed/racket]. However, -the mappings aren't called directly, and instead, in the body of @tc[m-house], -@tc[m-street] is shadowed by a function which returns a placeholder. This allows -us to not worry about mutually recursive mappings: a mapping can be called any -number of times with the same data, it will actually only be run once. - -The @tc[define-graph] macro will post-process the result of each mapping, and -replace the placeholders with promises for the the result of the mapping. The -promises are not available during graph construction, so there is no risk of -forcing one before it is available. - -We can now write the @tc[m-house] and @tc[m-person] mappings. - -@chunk[ - [(m-house [s : String] - [c : (Listof (Pairof String String))] - [p : String]) - (House (m-person p) (m-street c s))]] - -@chunk[ - [(m-person [p : String]) - (Person p)]] - -@subsubsection{Creating an instance of the graph} - -For now, we will supply directly the root arguments to the @tc[define-graph] -macro, as well as the node types and mappings. We can later curry the macro, so -that it first takes the node types and mappings, and produces a lambda taking -the root arguments as parameters. - -@chunk[ - (define-graph make-g ) - #;(define g (make-g )) - (define g1 (make-g )) - (define g g1)] - -@subsection{More details on the semantics} - -Let's take a second look at the root mapping: - -@chunk[ - [(m-city [c : (Listof (Pairof String String))]) - (City (remove-duplicates (map (curry m-street c) (cars c))) - (remove-duplicates (map m-person (cdrs c))))]] - -As this example shows, we can use @tc[m-street] as any other function, passing -it to @tc[curry], and calling @tc[remove-duplicates] on the results. Note that -each placeholder returned by @tc[m-street] will contain all information passed -to it, here a street name and @tc[c]. Two placeholders for @tc[m-street] will -therefore be @tc[equal?] if and only if all the arguments passed to -@tc[m-street] are @tc[equal?]. The placeholders also include a symbol specifying -which mapping was called, so two placeholders for two different mappings will -not be @tc[equal?], even if identical parameters were supplied. - -The node type allowing placeholders is derived from the ideal type given above. -Here, the type for @tc[Person] is @tc[[Person [name : String]]], so there are no -substitutions to make. Conversely, the type for @tc[City], originally expressed -as @tc[[(Listof Street) (Listof Person)]], will be rewritten as -@tc[[(Listof Street/placeholder-type) (Listof Person/placeholder-type)]]. - -The @tc[rewrite-type] module, which we use to derive types with placeholders -from the ideal ones, only handles a handful of the types offered by -@tc[typed/racket]. In particular, it does not handle recursive types described -with @tc[Rec] yet. - -@section{Implementation} - -In this section, we will describe how the @tc[define-graph] macro is -implemented. - -@subsection{The macro's syntax} - -We use a simple syntax for @tc[define-graph], and make it more flexible through -wrapper macros. - -@chunk[ - (define-graph name - [node … ] - …)] - -Where @tc[] is: - -@chunk[ - [field:id :colon field-type:expr]] - -And @tc[] is: - -@chunk[ - ((mapping:id [param:id :colon param-type:expr] …) - . mapping-body)] - -@subsection{The different types of a node} - -A single node name can refer to several types: - -@itemlist[ - @item{The @emph{ideal} type, expressed by the user, for example - @racket[[City (Listof Street) (Listof Person)]], it is never used as-is in - practice} - @item{The @emph{placeholder} type, type and constructor, which just store the - arguments for the mapping along with a tag indicating the node name} - @item{The @emph{incomplete} type, in which references to other node types are - allowed to be either actual (@racket[incomplete]) instances, or placeholders. - For example, @racket[[City (Listof (U Street Street/placeholder-type)) - (Listof (U Person Person/placeholder-type))]].} - @item{The @emph{with-indices} type, in which references to other node types - must be replaced by an index into the results list for the target node's - @racket[with-promises] type. For example, - @racket[[City (Listof (List 'Street/with-indices-tag2 Index)) - (Listof (List 'Person/with-indices-tag2 Index))]].} - @item{The @emph{with-promises} type, in which references to other node types - must be replaced by a @racket[Promise] for the target node's - @racket[with-promises] type. For example, - @racket[[City (Listof (Promise Street/with-promises-type)) - (Listof (Promise Person/with-promises-type))]].} - @item{The @emph{mapping function}, which takes some parameters and - returns a node (using the code provided by the user)}] - -We derive identifiers for these based on the @tc[node] name: - -@;;;; -@chunk[ - (define/with-syntax ((root-param …) . _) #'((param …) …)) - (define/with-syntax ((root-param-type …) . _) #'((param-type …) …)) - - (define-temp-ids "~a/make-placeholder" (node …) #:first-base root) - (define-temp-ids "~a/placeholder-type" (node …)) - (define-temp-ids "~a/placeholder-tag" (node …)) - (define-temp-ids "~a/placeholder-queue" (node …)) - - (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/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/index-type" (node …)) - (define-temp-ids "~a/with-indices→with-promises" (node …) - #:first-base root) - - (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/mapping-function" (node …)) - - (define-temp-ids "~a/database" (node …) #:first-base root) - - (define-temp-ids "~a/value" ((field …) …))] - -@subsection{Overview} - -The macro relies heavily on two sidekick modules: @tc[rewrite-type], and -@tc[fold-queue]. The former will allow us to derive from the ideal type of a -node the incomplete type and the with-promises type. It will also allow us to -search inside instances of incomplete nodes, in order to extract the -placehoders, and replace these parts with promises. The latter, @tc[fold-queue], -will be used to process all the pending placeholders, with the possibility to -enqueue more as new placeholders are discovered inside incomplete nodes. - -When the graph constructor is called with the arguments for the root parameters, -it is equivalent to make and then resolve an initial placeholder. We will use a -function from the @tc[fold-queue] library to process the queues of pending -placeholders, starting with a queue containing only that root placeholder. -We will have one queue for each placeholder type.@note{It we had only one queue, - we would have only one collection of results, and would need a @racket[cast] - when extracting nodes from the collection of results.} The element types of the -queues will therefore be these placeholder types. - -@chunk[ - node/placeholder-type] - -The return type for each queue will be the corresponding with-indices type. The -fold-queues function will therefore return a vector of with-indices nodes for -each node type. - -@chunk[ - node/with-indices-type] - - -@; Problem: how do we ensure we return the right type for the root? -@; How do we avoid casts when doing look-ups? -@; We need several queues, handled in parallel, with distinct element types. -@; * Several result aggregators, one for each type, so we don't have to cast -@; * Several queues, so that we can make sure the root node is of the expected -@; type. - -@; TODO: clarity. -@; The @tc[fold-queues] function allows us to associate each element with a tag, -@; so that, inside the processing function and outside, we can refer to an -@; element using this tag, which can be more lightweight than keeping a copy of -@; the element. -@; -@; We will tag our elements with an @tc[Index], which prevents memory leakage: -@; if we kept references to the original data added to the queue, a graph's -@; representation would hold references to its input, which is not the case when -@; using simple integers to refer to other nodes, instead of using the input for -@; these nodes. Also, it makes lookups in the database much faster, as we will -@; be able to use an array instead of a hash table. - -@subsection{The queues of placeholders} - -The fold-queues macro takes a root element, in our case the root placeholder, -which it will insert into the first queue. The next clauses are the queue -handlers, which look like function definitions of the form -@tc[(queue-name [element : element-type] Δ-queues enqueue) : result-type]. The -@tc[enqueue] argument is a function used to enqueue elements and get a tag in -return, which can later be used to retrieve the processed element. - -Since the @tc[enqueue] function is pure, it takes a parameter of the same type -as @tc[Δ-queues] representing the already-enqueued elements, and returns a -modified copy, in addition to the tag. The queue's processing body should return -two values: the result of processing the element, and the latest version of -@tc[Δ-queues], which stores the new elements to be added to the queue. - -@chunk[ - (fold-queues - [(node/placeholder-queue [e : ] - [Δ-queues : Δ-Queues] - enqueue) - : - ] - ...)] - -@subsection{Making placeholders for nodes} - -We start creating the root placeholder which we provide to @tc[fold-queues]. - -@chunk[ - (root/make-placeholder root-param …)] - -To make the placeholder, we will need a @tc[node/make-placeholder] function for -each @tc[node]. We first define the type of each placeholder (a list of -arguments, tagged with the @tc[node]'s name): - -@; TODO: maybe replace node types with placeholder types - -@chunk[ - (define-type node/placeholder-type - (List 'node/placeholder-tag - param-type …))] - -@; TODO: just use (variant [mapping param-type ...] ...) - -Then we define the @tc[node/make-placeholder] function: - -@chunk[ - (: node/make-placeholder (→ param-type … node/placeholder-type)) - (define (node/make-placeholder param …) - (list 'node/placeholder-tag param …))] - -@subsection{Making with-indices nodes} - -We derive the @tc[with-indices] type from each @emph{ideal} node type using the -@tc[tmpl-replace-in-type] template metafunction from the rewrite-type library. -We replace all occurrences of a @tc[node] name with an @tc[Index], which -indicates at which index in the queue's results the successor can be found. - -@; TODO: use a type-expander here, instead of a template metafunction. - -@CHUNK[ - (define-type node/index-type (List 'node/with-indices-tag2 Index)) - - (define-type node/with-indices-type - (List 'node/with-indices-tag …)) - - (: node/make-with-indices (→ … - node/with-indices-type)) - (define (node/make-with-indices field …) - (list 'node/with-indices-tag field …))] - -@CHUNK[ - (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 -the @tc[tmpl-replace-in-type] template metafunction from the rewrite-type -library. We replace all occurrences of a @tc[node] name with a @tc[Promise] for -that node's @tc[with-promises] type. - -@; TODO: use a type-expander here, instead of a template metafunction. - -@CHUNK[ - - (define-type node/with-promises-type - (tagged node/with-promises-tag - [field : ] …)) - - (: node/make-with-promises (→ … - node/with-promises-type)) - (define (node/make-with-promises field/value …) - (tagged node/with-promises-tag - [field : field/value] - …))] - -@CHUNK[ - (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 -the @tc[tmpl-replace-in-type] template metafunction from the rewrite-type -library. We replace all occurrences of a @tc[node] name with its -@tc[placeholder] type. - -@; TODO: use a type-expander here, instead of a template metafunction. - -@CHUNK[ - (define-type node/incomplete-type - (List 'node/incomplete-tag …)) - - (: node/make-incomplete (→ … - node/incomplete-type)) - (define (node/make-incomplete field …) - (list 'node/incomplete-tag field …))] - -@CHUNK[ - (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 -@chunk[ - (λ ([p : node/placeholder-type] [Δ-acc : Δ-Queues]) - : (values (List 'node/with-indices-tag2 Index) Δ-Queues) - (% index new-Δ-acc = (enqueue 'node/placeholder-queue p Δ-acc) - (values (list 'node/with-indices-tag2 index) - new-Δ-acc)))] - -@chunk[ - [node/placeholder-type - (List 'node/with-indices-tag2 Index) - (λ (x) (and (pair? x) - (eq? (car x) 'node/placeholder-tag))) - ]] - -@subsubsection{Processing the placeholders} - -@; TODO: also allow returning a placeholder (which means we should then -@; process that placeholder in turn). The placeholder should return the -@; same node type, but can use a different mapping? -@; Or maybe we can do this from the ouside, using a wrapper macro? - -@; TODO: we don't need that many let etc., use % instead once everything works. -@CHUNK[ - (let ([mapping-result (apply node/mapping-function (cdr e))]) - (let ([f (tmpl-fold-instance (List …) - Δ-Queues - …)]) - (let-values ([(r new-Δ-queues) (f (cdr mapping-result) Δ-queues)]) - (values (cons 'node/with-indices-tag r) - new-Δ-queues))))] - -Where @tc[] is the @tc[field-type] in which node types -are replaced by placeholder types: - -@chunk[ - (tmpl-replace-in-type field-type - [node node/placeholder-type] …)] - -@subsection{The mapping functions} - -We define the mapping functions as they are described by the user, with an -important change: Instead of returning an @emph{ideal} node type, we expect them -to return an @emph{incomplete} node type. - -@chunk[ - (: node/mapping-function (→ param-type … node/incomplete-type)) - (define node/mapping-function - (let ([mapping node/make-placeholder] - … - [node node/make-incomplete] - …) - (λ ([param : param-type] …) : node/incomplete-type - . mapping-body)))] - -@subsection{Returning a with-promises nodes} - -We will return a with-promises version of the root node, which contains promises -for its successors. The user can then force one of these to obtain the -with-promises version of the desired successor. - -@; TODO: put a diagram here, or an example at least - -This use of promises is safe, since their resolution depends only on the vectors -returned by fold-queues, which are already fully computed when we create the -root with-promises node. We therefore have no risk of forcing a promise that -can't be resolved, or that would depend on itself, causing an infinite loop. - -@subsubsection{Why use promises?} - -We use promises because we would like to only use immutable data structures. -Resolving the links in the graph would require mutating the nodes, so instead, -when extracting the @emph{placeholders} from an @emph{incomplete} node, we -produce a @emph{with-indices} node, which, instead of direct references to the -successors, just stores a tag and index. Later, the successors are processed, -and stored at the corresponding index in the queue for that tag. - -We then wrap each tagged index with a lambda, which also holds a reference to -the vectors returned by fold-queue, which containin all the with-indices nodes. -When calling the lambda, it extracts the with-indices node for that tag and -index, further replaces the tagged indices within, and returns a brand new -with-promises node. - -We could leave it as that, having the with-promises nodes contain lambdas -instead of actual references to their successors. However, when an immutable -function (like one of these lambdas) is called twice with the same arguments (in -this case none), @tc[typed/racket]'s occurrence typing currently does not infer -that the result will always be the same. This means that pattern-matching using -the @tc[match] macro won't work properly, for example. We therefore wrap these -functions into promises. The occcurrence typing mechanism in @tc[typed/racket] -knows that a promise will always return the same value when forced multiple -times. By default, promises use mutable data structures under the hood, to cache -their result, but we do not rely on that. We could use @tc[delay/name], which -doesn't cache the return value, but it was removed from @tc[typed/racket] -because @hyperlink["https://github.com/racket/typed-racket/issues/159"]{it - caused type safety problems}. - -@subsubsection{Creating with-promises nodes from with-indices ones} - -@chunk[ - [node/index-type - (Promise node/with-promises-type) - (λ (x) (and (pair? x) - (eq? (car x) 'node/with-indices-tag2))) - (λ ([tagged-index : node/index-type] [acc : Void]) - : (values (Promise node/with-promises-type) Void) - (values acc))]] - -TODO: check what we are closing over in that promise. -I think we are closing over the successor-with-index (but not its whole -database), as well as everything that the with-indices→with-promises function -closes over. - -@chunk[ - (let ([successor-with-index (vector-ref node/database - (cadr tagged-index))]) - (delay (node/with-indices→with-promises successor-with-index)))] - -@chunk[ - (: node/with-indices→with-promises (→ node/with-indices-type - node/with-promises-type)) - (define (node/with-indices→with-promises n) - (define f (tmpl-fold-instance (List …) - Void - …)) - (apply node/make-with-promises (first-value (f (cdr n) (void)))))] - -Where @tc[] is the @tc[field-type] in which node types -are replaced by tagged indices: - -@chunk[ - (tmpl-replace-in-type field-type [node node/index-type] …)] - -@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -@comment[#| - @subsection{Converting incomplete nodes to with-promises ones} - - @chunk[ - [node/incomplete-type - node/with-promises-type - (λ (x) (and (pair? x) (eq? (car x) 'node/incomplete-tag))) - (λ ([x : node/incomplete-type] [acc : Void]) - )]] - - @chunk[ - [mapping/placeholder-type - (tmpl-replace-in-type result-type [node node/with-promises-type] …) - (λ (x) (and (pair? x) (eq? (car x) 'mapping/placeholder-tag))) - (λ ([x : mapping/placeholder-type] [acc : Void]) - )]] - - @; TODO: this would be much simpler if we forced having only one mapping per - @; node, and extended that with a macro. - - @chunk[ - (define/with-syntax ((node/compatible-mappings ...) ...) - (for/list ([x (in-syntax #'(node ...))]) - (multiassoc-syntax - x - #'([result-type . mapping] - …))))] - - @chunk[ - (error (~a "Not implemented yet " x))] - - @chunk[ - (% index new-Δ-queues = (enqueue 'mapping/placeholder-tag x Δ-queues) - (list 'mapping/placeholder-tag index) - (error (~a "Not implemented yet " x)))] - |#] - -@section{Putting it all together} - -@chunk[ - (define-syntax/parse - - #|((λ (x) (pretty-write (syntax->datum x)) x)|# - (template - ;(let () - (begin - (begin ) … - (begin ) … - (begin ) … - (begin ) … - (begin ) … - (begin ) … - - (: name (→ root-param-type … (Promise root/with-promises-type))) - (define (name root-param …) - (match-let ([(list node/database …) ]) - (begin ) … - (let ([root/with-promises (root/with-indices→with-promises - (vector-ref root/database 0))]) - (delay root/with-promises)))))))] - -@chunk[ - (module main typed/racket - (require (for-syntax syntax/parse - racket/syntax - syntax/stx - syntax/parse/experimental/template - racket/sequence - "rewrite-type.lp2.rkt" - "../lib/low-untyped.rkt") - "fold-queues.lp2.rkt" - "rewrite-type.lp2.rkt" - "../lib/low.rkt" - "structure.lp2.rkt" - "variant.lp2.rkt" - "../type-expander/type-expander.lp2.rkt") - - ;(begin-for-syntax - ;) - - (provide define-graph) - )] - -In @tc[module-test], we have to require @tc[type-expander] because it provides a -@tc[:] macro which is a different identifier than the one from typed/racket, -therefore the @tc[:] bound in the @tc[graph] macro with @tc[:colon] would -not match the one from @tc[typed/racket] - -@chunk[ - (module* test typed/racket - (require (submod "..") - "fold-queues.lp2.rkt"; DEBUG - "rewrite-type.lp2.rkt"; DEBUG - "../lib/low.rkt"; DEBUG - "structure.lp2.rkt"; DEBUG - "variant.lp2.rkt"; DEBUG - "../type-expander/type-expander.lp2.rkt" - typed/rackunit) - - (provide g) - )] - -The whole file, finally: - -@chunk[<*> - (begin - - - (require 'main) - (provide (all-from-out 'main)) - - )] diff --git a/graph-lib/graph/graph_old.lp2.rkt b/graph-lib/graph/graph_old.lp2.rkt new file mode 100644 index 00000000..42a3b6fb --- /dev/null +++ b/graph-lib/graph/graph_old.lp2.rkt @@ -0,0 +1,884 @@ +#lang scribble/lp2 +@(require "../lib/doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Graph implementation} + +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, 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. + +@(table-of-contents) + +@section{Notes on complex transform result types} + +We wish at one point to support complex result types for the transforms, instead +of only allowing a single node type. + +We have to impose a constraint: do not have a cycle inside the transform's +result that doesn't go through a node, since we break cycles by replacing nodes +with a promise. The safest way to satisfy that constraint is to enforce the +absence of loops at the type level. + +We would then inline the called transform's results, breaking the cycles by +replacing nodes with a thunk that returns the desired node. That thunk will be +wrapped into a Promise that calls it, so that typed/racket's occurrence typing +is happy, but we don't rely on the memoization semantics. + +@subsection{Compile-time handling of complex transform result types} + +During macro-expansion, we generate procedures that process nodes found in +transforms' results, by inlining the results of called transforms. If we find a +@tc[transform/link-request] type in some place we don't know how to rewrite +(like a function type, for example), we throw an error. Similarly, if we +encounter a cycle in the type that does not go through a node type, we throw an +error. + +These procedures will help generate code to make a facade node from the +incomplete one. When inlining results from called transforms, they will request +other incomplete nodes from the database. + +@subsection{Two-step graph creation} + +Writing a graph-generation macro that allows complex return types for transforms +seems difficult, and it would be easier to write a simple graph-generation +macro, that only accepts transforms with return a single node type. We could +build on top of that a more flexible macro, that would first generate a graph +where each transform's result is wrapped in an ad-hoc single-field node. Then, +we would automatically generate a second graph transformation that produces the +desired nodes from that graph. + +Example: transform @tc[t1] takes a list of numbers as input, and produces a list +of either calls to transform @tc[t2] or nodes @tc[ni] as output. The @tc[t2] +transform generates a pair of nodes @tc[(ni [x Number])] and +@tc[(nj [y String])]. + +The user would describe the graph like this: + +@chunk[ + (make-graph ([root (Listof (U ni (Pairof ni nj)))] + [ni [x Number]] + [nj [y String]]) + [(t1 [ln : (Listof Number)] : (Listof (U ni t2)) + (map (λ (x) (if (even? x) + (t2 x) + (ni x))) + ln))] + [(t2 [n : Number] : (Pairof ni nj) + (cons (ni n) (nj (format "~a" n))))])] + +In the above, the result type of @tc[t1] has to be @tc[(Listof (U ni t2))] +instead of @tc[(Listof (U ni (Pairof ni nj)))], because otherwise we can't +easily automatically infer that @tc[(Pairof ni nj)] was actually @tc[t2], +without looking at the body of the transform. In a more advanced version, we +could substitute every @tc[result-type] found in another transform's +@tc[result-type] by @tc[(U result-type transform/link-request)], however that +would likely produce spurious cycles that do not go through a node, so it's +probably best to make things explicit, and let the user write @tc[U]. + +@chunk[ + (graph ([r-t1 [result (Listof (U ni t2))]] + [r-t2 [result (Pairof ni nj)]]) + [(t1 [ln : (Listof Number)] : r-t1 + (r-t1 (map (λ (x) (if (even? x) + (t2 x) + (ni x))) + ln)))] + [(t2 [n : Number] : r-t2 + (r-t2 (cons (ni n) + (nj (format "~a" n)))))])] + +Then use this graph transform: + +@chunk[ + (make-graph ([root [result (Listof (Pairof ni nj))]] + [ni [x Number]] + [nj [y String]]) + [(r-t1→root [t1 : r-t1]) : root + (root (map (λ (v) + (match v + [(? list?) (r-t2-result v)] + [(ni _) v])) + (r-t1-result t1)))])] + +@subsection{Many to one transforms} + +This example covers one to many transforms. What about many to one transforms? +The macro we are building allows generating graphs, but does not care about the +input. In the case were transforming a graph of @tc[house]s, @tc[street]s and a +@tc[city], and we want to condense all the @tc[house]s on one side of each +@tc[street] to a @tc[suburb], we would write a transform @tc[t1] for@tc[street] +which passes the whole list of @tc[house]s to a transform @tc[t2]. The @tc[t2] +transform would create a @tc[suburb] from those, without calling a transform for +each @tc[house]. + +@subsection{Implicit rule names} + +In order to allow implicit rule names, when there's only one rule with the +desired result node, we can use the node's name as the transform name. We should +think about naming conflicts: when calling @tc[n], should it insert a link +request for the transform, or should it create an incomplete node? + +@subsection[#:tag "graph|complex-transforms-return-type-conclusion"]{Conclusion} + +With this approach, we can write the graph creation macro with the guaranty +that the result of a transform always is exactly one node type. More complex +transform result types can be decomposed into to two passes. + +A downside is that we can't inspect the result of a call to another transform, +since it's not actually calling it, and we're only getting an opaque link +request back. We couldn't call the other transform anyway, because it could half +of the time return a value immediately, and half of the time call us back (with +the same arguments), causing an infinite loop. For that, we could declare some +#:helper transforms, that get called immediately (but if they run into an +infinite loop it's not our fault). + +@section{Comparison with @racket[make-placeholder] and + @racket[make-reader-graph]} + +Comparison of this approach with @tc[make-placeholder] and +@tc[make-reader-graph]: + +@itemlist[ + @item{They don't guarantee at compile-time that you'll fill in all + placeholders. We could use @racket[make-placeholder] and + @racket[make-reader-graph] wrapped inside a macro that makes sure that all + placeholders are filled (same approach as we have).} + @item{I don't think you can iterate over all the nodes or over the nodes of a + specific type, and @racket[make-placeholder] isn't typed (yet) anyway I + guess).}] + +@section{Constructor} + +Here is an overview of the architecture of the graph constructor: + +@itemlist[ + @item{We first save the parameter types in the old context, because we later + shadow the node names, and the parameters should refer to the old types. + Depending on how we write the rest, this might not be necessary though, since + it is possible we need to write @racket[(og node)] to refer to nodes types + from the old graph @racket[og].} + @item{We then define the node names as constructors for incomplete types — + which means that they can contain link requests for the results other + transforms} + @item{We define data structures representing link requests. Each link request + encapsulates a thunk that performs the transform's work when called, as well + as the name of the transform and its arguments, used to detect when we have + two identical link requests (which can be due to cycles in the resulting + graph, for example).} + @item{We then define the transforms as procedures that return a link request.}] + +@chunk[ + (define-syntax/parse + (make-graph-constructor ([node (field:id field-type:expr) ...] ...) + [transform:id (param:id param-type:expr) ... + (~literal :) result-type:id + body ...] + ...) + + + + + + + #`(let () + + (let () + + + + + + make-graph-database)))] + +@chunk[ + (define make-g (make-graph-constructor + ([ma (fav String) (faa ma) (fab mb)] + [mb (fbv String) (fba ma)]) + [transform-a (s String) : ma + (ma s + (transform-a s) + (transform-b "b"))] + [transform-b (s String) : mb + (mb s + (transform-a s))])) + (make-g "root-arg")] + +@subsection{Saving parameter types in old context} + +@chunk[ + (define/with-syntax ((param-type/old ...) ...) + (stx-map (λ (ps) + (with-syntax ([(t sps ...) ps]) + (format-temp-ids "~a/~a/memorized-type" #'t #'(sps ...)))) + #'((transform param ...) ...)))] + +@chunk[ + (define-type param-type/old param-type) + ... + ...] + +@subsection{Incomplete nodes} + +When a transform returns an object, it is incomplete (it potentially contains +link requests instead of actual references to the nodes). + +We prepare some template variables. The first is the name of the tagged variant +representing an incomplete node: + +@chunk[ + (define/with-syntax (node/incomplete ...) + (format-temp-ids "~a/incomplete" #'(node ...)))] + +Then, we build a reverse map, which from a node type obtains all the transforms +returning that node type. More specifically, we are interested in the +transform's link request type. + +@chunk[ + (define/with-syntax ((node/link-request-types ...) ...) + (for/list ([x (in-syntax #'(node ...))]) + (multiassoc-syntax x + #'([result-type . transform/link-request] ...))))] + +The third template variable we define maps transforms to the incomplete type for +their returned node. + +@chunk[ + (define/with-syntax (transform/result-node/incomplete ...) + (for/list ([x (in-syntax #'(result-type ...))]) + (assoc-syntax x #'([node . node/incomplete] ...))))] + +@CHUNK[ + (define-type node (U node/link-request-types ...) + #:omit-define-syntaxes) + ... + (define-tagged node/incomplete [field field-type] ...) + ... + (define-multi-id node + #:match-expander-id node/incomplete + #:call-id node/incomplete) + ...] + +@subsection{Link requests for nodes} + +When a transform wants to produce a reference to the result of another transform +of some data, it generates instead a link request, which encapsulates the +desired transform and arguments, without actually performing it. + +@chunk[ + (define/with-syntax (transform/link-request ...) + (format-temp-ids "~a/link-request" #'(transform ...)))] + +Due to an issue with @tc[typed/racket] (@tc[struct]s aren't properly declared +inside a @tc[let]), we need to pre-declare the @tc[transform/link-request] +@tc[struct]. Since the call to make-graph could itself be inside a @tc[let], we +need to pre-declare it in this file, instead of declaring it at the top of the +macro. + +We're making the structure transparent for easier debugging, but at the time of +writing this, it needs not be. + +@chunk[ + (struct (TKey) + transform/link-request-pre-declared + ([key : TKey]) + #:transparent)] + +@chunk[ + (define-type transform/link-request + (transform/link-request-pre-declared + (List 'transform + param-type/old ...))) + ...] + +@subsection{Transforms} + +@chunk[ + (define/with-syntax (transform/link-request→incomplete ...) + (format-temp-ids "~a/link-request→incomplete" #'(transform ...)))] + +@chunk[ + (begin + (: transform/link-request→incomplete + (→ param-type/old ... transform/result-node/incomplete)) + (define (transform/link-request→incomplete param ...) + body ...)) + ...] + +@chunk[ + (begin + (: transform + (→ param-type/old ... transform/link-request)) + (define (transform param ...) + ((inst transform/link-request-pre-declared + (List 'transform + param-type/old ...)) + (list 'transform param ...)))) + ...] + +@section{Queue} + +@chunk[ + (define/with-syntax (root-transform . _) #'(transform ...)) + (define/with-syntax ((root-transform/param-type ...) . _) + #'((param-type ...) ...)) + (define/with-syntax ((root-transform/param ...) . _) + #'((param ...) ...)) + (define/with-syntax (transform/transformed ...) + (format-temp-ids "~a/transformed" #'(transform ...))) + (define/with-syntax (root-transform/link-request . _) + #'(transform/link-request ...)) + (define/with-syntax recursive-call + #'(process-queue pending-requests + processed-requests + transform/transformed ...)) + (define/with-syntax (node/extract-link-requests ...) + (format-temp-ids "~a/extract-link-requests" #'(node ...))) + + + ] + +To build the graph database, we take the parameters for the root transform, and +return lists incomplete nodes (one for each transform). + +The parameters for the root transform, addition to the transform's name, form +the first link request. To fulfil this link request and the ones found later, +we call the desired transform which returns an incomplete node. We extract any +link requests found in that incomplete node, and queue them. The incomplete node +itself is added to the appropriate list, to be returned once the queue has been +fully processed. + +@CHUNK[ + (: make-graph-database + (→ root-transform/param-type ... + (List (Listof transform/result-node/incomplete) ...)))] + +The @tc[make-graph-database] function consists mainly in the process-queue +function, which takes a queue for each transform, and a list of +already-processed incomplete nodes for each transform, and returns these lists, +once all queues are empty. + +@CHUNK[ + (define (make-graph-database root-transform/param ...) + (: process-queue (→ (Setof (U transform/link-request ...)) + (Setof (U transform/link-request ...)) + (Listof transform/result-node/incomplete) + ... + (List (Listof transform/result-node/incomplete) + ...))) + (define (process-queue pending-requests + processed-requests + transform/transformed + ...) + ;; TODO: Can probably be moved out. + ) + + )] + +The @tc[process-queue] function is initially called with empty lists for all +queues and all result lists, except for the root transform's queue, which +contains the initial link request. + +@CHUNK[ + (process-queue (set (root-transform root-transform/param ...)) + (set) + (begin 'transform/transformed '()) + ...)] + +Process-queue is a standard queue handler using sets. + +@CHUNK[ + (if (set-empty? pending-requests) + (list transform/transformed ...) + (let* ([request (set-first pending-requests)] + [pending-requests (set-rest pending-requests)] + [processed-requests (set-add processed-requests request)] + [tag (car (transform/link-request-pre-declared-key request))]) + ))] + +To process each link request, we first match on its type, and once we found it, +we call the result thunk, extract any link requests contained within, and add +those to the queue. + +@CHUNK[ + (cond + [(eq? tag 'transform) + (let* ([transformed + : transform/result-node/incomplete + (apply transform/link-request→incomplete + (cdr (transform/link-request-pre-declared-key + request)))] + [transform/transformed + (cons transformed transform/transformed)] + [extracted + (list->set + (transform/result-node/extract-link-requests transformed))] + [pending-requests + (set-union pending-requests + (set-subtract extracted processed-requests))]) + recursive-call)] + ...)] + +@subsection[#:tag "graph|TODO3"]{TODO} + +We need to traverse the @tc[transformed] node (which is an incomplete node), +and find the link requests within. These link requests will be added to the +corresponding @tc[pending-requests] queue. Below is the body of a for-syntax +function that transforms a type with link-requests into the @tc[match] patterns +that will be used at run-time to traverse the incomplete node. In most cases, +there is only one pattern, but the @tc[U] requires one for each possibility. + +When we encounter a link request, we prepend it to the corresponding queue. +For the type @tc[(List Number n/link-request)], the function will look like +this: + +@chunk[ + (match transformed + [(list a b) + (match a [a2 a2]) + (match b [(and t + (transform/link-request-pre-declared + (cons 'transform1 _))) + (set! pending-requests + (cons t pending-requests))])])] + +@subsubsection{Match clauses} + +We first transform the type into the different match clauses. For that, we +define the @tc[fold-type-clauses] function, which takes the identifier to +destructure at run-time, and its type. The function returns a list of clauses. + +@chunk[ + (define (fold-type-clauses val t) + (syntax-parse t + ))] + +When a link request is found in the type, we produce the corresponding match +clause, which body prepends the request to the queue of pending requests. For +now we use @racket[set!] to prepend the request, but it would be cleaner to use +recursion. We wouldn't even need to flatten the pending-requests list, because +it could be a tree instead of a flat list, since we only need to add to it and +later pop elements. + +TODO: we currently ignore potential hiding of identifiers due to type variables +bound by Rec, for example. This is a case where having a fold-type function +provided by the type-expander library would be interesting. + +@CHUNK[ + [x:id + #:when (ormap (curry free-identifier=? #'x) + (syntax->list #'(node/incomplete ...))) + (define/with-syntax (this-field-type ...) + (assoc-syntax #'x #'((node/incomplete field-type ...) ...))) + + (define/with-syntax (tmp ...) + (generate-temporaries #'(this-field-type ...))) + #`([(x tmp ...) + (append #,@(stx-map fold-type + #'(tmp ...) + #'(this-field-type ...)))])]] + +@CHUNK[ + [x:id + #:when (ormap (curry free-identifier=? #'x) + (syntax->list #'(node ...))) + #`([(and t (transform/link-request-pre-declared (cons 'transform _))) + (cons (ann t transform/link-request) '())] + ...)]] + +We handle fixed-length lists by calling @tc[fold-type] on each element type. + +@CHUNK[ + [((~literal List) a ...) + (define/with-syntax (tmp ...) (generate-temporaries #'(a ...))) + #`([(list tmp ...) + (append #,@(stx-map fold-type #'(tmp ...) #'(a ...)))])]] + +We iterate variable-length lists at run-time. + +@CHUNK[ + [((~literal Listof) a) + #`([(list tmp (... ...)) + (append-map (λ (tmp1) #,(fold-type #'tmp1 #'a)) + tmp)])]] + +Pairs and vectors are handled similarly: + +@CHUNK[ + [((~literal Pairof) a b) + #`([(cons tmpa tmpb) + (list #,(fold-type #'tmpa #'a) + #,(fold-type #'tmpb #'b))])]] + +@CHUNK[ + [((~literal Vectorof) a) + #'([(vector tmp (... ...)) + (append-map (λ (tmp1) #,(fold-type #'tmp1 #'a)) + tmp)])]] + +For unions, we return several clauses, obtained via a recursive call to +@tc[fold-type-clauses]. + +@CHUNK[ + [((~literal U) a ...) + #`(#,@(stx-map fold-type-clauses val #'(a ...)))]] + +We handle other cases by leaving them as-is, but we still check that they don't +contain a reference to a node type, because we would otherwise leave the +link-request there. + +And the fourth maps transforms to the link-requests extraction procedure for +their returned node. + +@chunk[ + (define/with-syntax (transform/result-node/extract-link-requests ...) + (for/list ([x (in-syntax #'(result-type ...))]) + (assoc-syntax x #'([node . node/extract-link-requests] ...))))] + +The last case is when we encounter an unknown type. We assume that it does not +contain any link-requests and therefore return an empty list. + +@CHUNK[ + [x:id + #`([_ '()])]] + +@subsubsection{Folding the type: extracting link requests} + +The for-syntax function @tc[fold-type] generates code that uses @tc[match] to +extract the @tc[link-request]s from an incomplete node (or part of it) with type +@tc[t]. The match clauses are those returned by @tc[fold-type-clauses] defined +above. + +@CHUNK[ + (define (fold-type val t) + #`(begin + (match #,val #,@(fold-type-clauses val t))))] + +@subsubsection{Fold function for each incomplete node} + +For each node type, we wish to declare a function that extracts link requests +from the incomplete type. We should work on the expanded type. + +@chunk[ + (define-template-metafunction (fold-type-tmpl stx) + (syntax-case stx () [(_ val t) (fold-type #'val #'t)]))] +@CHUNK[ + #,@(for/list ([name (in-syntax #'(node/extract-link-requests ...))] + [val-type (in-syntax #'(node/incomplete ...))] + [field-types (in-syntax #'((field-type ...) ...))]) + #`(define (#,name [val : #,val-type]) + : (Listof (U transform/link-request ...)) + #,(fold-type #'val val-type)))] + +@subsubsection[#:tag "graph|TODO1"]{TODO} + +Later, we will replace link requests with thunks returning the desired node, +wrapped in a promise in order to please occurrence typing. Below is the body of +the for-syntax function that transforms a type with link-requests into a type +with actual nodes. It's probably not useful, because we obtain the same result +with scopes. + +@CHUNK[ + [x:id + #:when + (ormap (curry free-identifier=? #'x) + (syntax->list #'(node/link-request ...))) + #`(Promise (→ #,(assoc-syntax #'x #'((node/link-request . node) ...))))] + [((~literal List) a ...) #`(List #,@(stx-map fold-type #'(a ...)))] + [((~literal Listof) a) #`(Listof #,@(stx-map fold-type #'(a ...)))] + [((~literal Pairof) a b) #`(Pairof #,(fold-type #'a) #,(fold-type #'b))] + [((~literal Vectorof) a) #'(Vectorof #,(fold-type #'a))] + [((~literal U) a ...) #'(U #,(stx-map fold-type #'(a ...)))]] + +@section{@racket[incomplete] type-expander} + +We define a @tc[type-expander] @tc[(incomplete n)] that returns the incomplete +node type for the node type @tc[n]. This type-expander allows the user to refer +to the incomplete type of the node in the body of a transform, if annotations +are needed for a value containing such a node. + +@chunk[ + (define-type-expander (incomplete stx) + (syntax-case stx () + [(_ n) + (raise-syntax-error + 'incomplete + (format "Type doesn't have an incomplete counterpart: ~a" + (syntax->datum #'n)) + #'n)]))] + +@chunk[ + (define-type-expander (outer-incomplete stx) + (syntax-case stx () [(_ n) #'(incomplete n)]))] + +@chunk[ + (let () + + (let () + (define-type node + (tagged node [field (Promise field-type)] ...)) + ... + + (define-type node/incomplete + ;; TODO: substitute link-requests here + (tagged node [field (Promise field-type)] ...)) + + (define-type-expander (incomplete stx) + (syntax-parse stx () + [(_ (~litral node)) #'node/incomplete] + [_ #'(outer-incomplete n)])) + ))] + +@section{Transforming @racket[incomplete] nodes into complete ones} + +@subsection{Initial version} + +We will start with a very simple traversal function, that will just substitute +link requests immediately in the fields of a node. + +@chunk[ + (define (substitute-link-requests v) + (match v + [(node/incomplete field ...) + (node ...)] + ...))] + +@chunk[ + (match field + [(transform/link-request key _) (transform/key→promise key)] ;; TODO + ...)] + +@chunk[ + ] + +@subsection{More complex attempt} + +We know for sure that all references to future nodes are actually incomplete +ones, but we have no guarantee about the contents of the fields of a node. Since +they may contain a mix of link requests and primitives (via a @tc[U] type for +example), and may contain lists of nodes etc. we need to traverse them at +run-time, in order to find and replace references to link requests. + +However, if we were to write this as a simple recursive function, we wouldn't be +able to express its type without knowing anything about the node's type: + +@chunk[ + (case→ (→ node/link-request node) ... + (→ (Pairof may-contain-link-request + may-contain-link-request) + (Pairof doesnt-contain-link-request + doesnt-contain-link-request)))] + +Writing the @tc[may-contain-link-request] and @tc[doesnt-contain-link-request] +as functions, while expressing the contraint that the output is the same type as +the input — except for the link requests that turned into nodes, would be +impossible in typed/racket. I suppose that with GADTs one could write such a +type. + +Instead, we will, during macro-expansion, traverse the type, and generate +conversion procedures accordingly. + +@chunk[ + [(~literal node/link-request) #''link-request] + ... + [((~literal List) a ...) #'(List #,@(stx-map fold-type #'(a ...)))] + [((~literal Listof) a) #''Listof] + [((~literal Pairof) a) #''Pairof] + [((~literal Vectorof) a) #''Vectorof] + [((~literal U) a ...) #''U]] + +@chunk[ + (→ (List a ...) (List replaced-a ...))] + +@chunk[ + [(list? v) (map traverse-list v)] + [(pair? v) (cons (traverse-list (car v)) + (traverse-list (cdr v)))] + [(vector? v) ]] + +@subsection{Unions} + +Unions are difficult to handle: At one extreme, we confuse two different types +like @tc[(Listof Number)] and @tc[(Listof String)], by using just the @tc[list?] +predicate. On the other end of the spectrum, we try to distinguish them with +@tc[typed/racket]'s @tc[make-predicate], which doesn't work in all cases. + +Handling this in the best way possible is out of the scope of this project, so +we will just add special cases as-needed. + +@subsection{Unhandled} + +We currently don't handle structure types, prefab structures, hash tables, +syntax objects and lots of other types. + +On the other hand, we can't handle fixed-length @tc[(Vector ...)] types, because +occurrence typing currently can't track which case we are in when we check the +length with @tc[(vector-length constant)]. We also can't handle functions, for +hopefully obvious reasons. + +@; TODO: insert a link to the type-expander document in the paragraph below. + +We run into a problem though with types declared via define-type without +informing the type-expander. The type-expander handles these by expanding just +their arguments, and leaving the type untouched, but we can't ignore them in our +case. + +For all these other cases, we'll just check that they don't contain any +reference to a link-request type. + +@chunk[ + [other + (fold-check-no-link-requests #'other) + #'other]] + +The checker below is approximate, and is just meant to catch the error as soon +as possible, and we include a fall-back case for anything we couldn't handle +properly. If we let a link-request slip, it should be caught by the type +checker, unless it is absorbed by a larger type, like in +@tc[(U Any link-request)], in which case it doesn't matter. + +@chunk[ + (define (fold-check-no-link-requests stx) + (syntax-parse stx + [(~and whole (~or (~literal node/link-request) ...)) + (raise-syntax-error + 'graph + "Found a link request buried somewhere I can't access" + whole)] + [(~and whole (t ...)) + (stx-map fold-check-no-link-requests #'(t ...))] + [whole whole]))] + +@section[#:tag "graph|TODO2"]{TODO} + +@chunk[ + (define (multiassoc-syntax query alist) + (map stx-cdr + (filter (λ (xy) (free-identifier=? query (stx-car xy))) + (syntax->list alist)))) + (define (assoc-syntax query alist) + (let ([res (assoc query (map syntax-e (syntax->list alist)) + free-identifier=?)]) + (unless res (raise-syntax-error '? (format "Can't find ~a in ~a" + query + alist))) + (cdr res)))] + +@CHUNK[ + ;; The actual traversal code: + ;; TODO: write a tail-recursive version, it's cleaner than using set!. + (: make-graph-database + (→ root-transform.param.type ... + (case→ (→ 'node.name (Listof (Pairof Any node.incomplete))) + ...))) + (define (make-graph-database root-transform.param.name ...) + (let ([pending : (Listof (U node.link-request ...)) + (list (cons (list 'root-transform.name + root-transform.param.name ...) + (λ () (root-transform.function + root-transform.param.name ...))))] + [all-transformed : (Listof (Pairof Symbol Any)) '()] + ;; the key is actually the second element in a + ;; link-request-???, but should be just a number like in + ;; the C# version. + [node.transformed : (Listof (Pairof Any node.incomplete)) '()] + ...) + (do : (case→ (→ 'node.name (Listof (Pairof Any node.incomplete))) + ...) + () + [(null? pending) + (ann (λ (selector) + (cond [(eq? selector 'node.name) node.transformed] ...)) + (case→ (→ 'node.name (Listof (Pairof Any node.incomplete))) + ...))] + (let ((request (car pending))) + ;; Must be immediately after the (let (...), because we cons to + ;; that list in the block below. + (set! pending (cdr pending)) + ;; Skip already-transformed link requests. TODO: map a number + ;; for each. + (unless (member (car request) all-transformed) + ;; Call the lambda-part of the request. + (let ([transformed ((cdr request))]) + (cond + [(eq? (car transformed) 'node.name) + (set! pending + (list* ((cdr transformed) + 'node/field-filter-out-primitives/name) + ... + pending)) + (set! all-transformed (cons (car request) + all-transformed)) + (set! node.transformed + (cons (cons (car request) (cdr transformed)) + node.transformed))] + ... + ;; Make sure all cases are treated, at compile-time. + [else (typecheck-fail #'#,stx + "incomplete coverage")])))))))] + +@section{Tests} + +@chunk[ + (values)] + +@section{Conclusion} + +@chunk[<*> + (begin + (module main typed/racket + (require (for-syntax racket/sequence + ;; in-syntax on older versions + ;;;unstable/sequence + syntax/parse + syntax/parse/experimental/template + racket/syntax + racket/function + syntax/stx + racket/pretty + "../lib/low-untyped.rkt" + "../lib/untyped.rkt") + (prefix-in DEBUG-tr: typed/racket) + syntax/parse + "../lib/low.rkt" + "structure.lp2.rkt" + "variant.lp2.rkt" + "../type-expander/multi-id.lp2.rkt" + "../type-expander/type-expander.lp2.rkt") + (provide make-graph-constructor + #|graph|#) + + (begin-for-syntax + ) + + + + + #||#) + + (require 'main) + (provide (all-from-out 'main)) + + (module* test typed/racket + (require (submod "..") + "../type-expander/type-expander.lp2.rkt" + "../lib/test-framework.rkt") + + ;; Debug + + (require syntax/parse + "../lib/low.rkt" + "structure.lp2.rkt" + "variant.lp2.rkt" + "../type-expander/multi-id.lp2.rkt" + "../type-expander/type-expander.lp2.rkt") + ;; + + + ))] diff --git a/graph-lib/graph/map.rkt b/graph-lib/graph/map.rkt index 98ecc516..0f361258 100644 --- a/graph-lib/graph/map.rkt +++ b/graph-lib/graph/map.rkt @@ -1,206 +1,214 @@ -#lang debug typed/racket +#lang typed/racket (require (for-syntax racket/syntax + racket/function syntax/stx syntax/parse - syntax/parse/experimental/template "../lib/low-untyped.rkt") - (for-meta 2 - racket/base - racket/syntax) "../lib/low.rkt" - "map1.rkt" - "graph4.lp2.rkt" + "get.lp2.rkt" "../type-expander/type-expander.lp2.rkt") -(provide map: apply-compose) ;; TODO: move apply-compose to lib/low.rkt +(module m typed/racket + (provide car! cdr!) + + (: car! (∀ (A) (→ (U (Listof A) (Pairof A Any)) A))) + (define (car! x) (if (pair? x) + (car x) + (car x))) + + (: cdr! (∀ (A) (case→ (→ (Listof A) (Listof A)) + (→ (Pairof Any A) A)))) + (define (cdr! x) (cdr x))) -(begin-for-syntax - (define-syntax-class lam - (pattern (~or (~literal λ) (~literal lambda)))) - (define-syntax-class mapp - (pattern (~or (~literal map) (~literal map:))))) +(require 'm) +(provide (all-from-out 'm)) -(define-for-syntax (remove-identities stx) +(provide map: compose-maps) + +(define-syntax (dbg stx) (syntax-parse stx - [() #'()] - [((~or (~lit identity) (~lit values) (~lit compose)) . rest) - (remove-identities #'rest)] - [([(~literal compose) . fs] . rest) - (define/with-syntax cleaned-fs (remove-identities #'fs)) - (syntax-parse #'cleaned-fs - [() (remove-identities #'rest)] - [(one-f) #`(one-f . #,(remove-identities #'rest))] - [some-fs #`((compose . some-fs) . #,(remove-identities #'rest))])] - [(f . rest) - #`(f . #,(remove-identities #'rest))])) - -;; TODO: check that we don't bork the literals identity, values and compose -;; inside macros or function calls, or alter them in any other way, e.g. -;; (map: (compose identity (λ (values) (+ values 1)) identity) '(1 2 3)) -;; or -;; (define (calltwice f) (λ (x) (f (f x)))) -;; (map: (compose (calltwice identity)) '(1 2 3)) -;; Although a poor variable name choice, the two occurences of "values" in the -;; first example shouldn't be altered, and the λ itself shouldn't be touched. -;; In the second one, everything inside the calltwice function call should be -;; left intact. -(define-for-syntax (remove-identities1 stx) - (syntax-parse (remove-identities #`(#,stx)) - [() #'identity] - [(f) #'f])) + [(_ (~optional (~and norun #:norun)) code) + (if (attribute norun) + #'(ann 'code Any) + #'code)])) (begin-for-syntax - (define-syntax-class map-info - (pattern (_ #:in in-type - #:in-∀ [in-∀ …] - #:out out-type - #:∀ (∀-type …) - #:arg-funs ([arg-fun - param-fun - (~optional (~and auto-in #:auto-in)) - fun-in fun-out] …) - #:funs [fun …])))) + (define-syntax-class >0 (pattern :exact-positive-integer))) (begin-for-syntax - (define-syntax (mk-info stx) - (syntax-case stx () - [(_ . rest-stx) - (begin - (define/with-syntax whole-stx (syntax/loc stx (info . rest-stx))) - #'(syntax-parse #`whole-stx - [i:map-info #'i]))]))) + (define-syntax-class ≥0 (pattern :exact-nonnegative-integer))) -(define-for-syntax (:map* stx* stx-&ls stx-out stx-out-∀) - (if (stx-null? stx*) - '() - (syntax-parse (:map (stx-car stx*) stx-&ls stx-out stx-out-∀) - [info:map-info - (let ([r (:map* (stx-cdr stx*) stx-&ls #'info.in-type #'[info.in-∀ …])] - [auto (attribute info.auto-in)]) - (if (and (not (null? auto)) (car auto) (not (null? r))) - (syntax-parse (car r) - [r-info:map-info - (let ([intact #'([info.arg-fun - info.param-fun - info.fun-in ;;; - info.fun-out] …)] - [replaced #'([info.arg-fun - info.param-fun - r-info.out-type ;;info.fun-in ;;; - info.fun-out] …)]) - (cons (mk-info #:in info.in-type - #:in-∀ [info.in-∀ …] - #:out info.out-type - #:∀ (info.∀-type …) - #:arg-funs (#,(stx-car replaced) - #,@(stx-cdr intact)) - #:funs [info.fun …]) - r))]) - (cons #'info r)))]))) - -(define-for-syntax (:map stx stx-&ls stx-out stx-out-∀) - (define/with-syntax (&l …) stx-&ls) - (define/with-syntax out stx-out) - (define/with-syntax (out-∀ …) stx-out-∀) - (syntax-parse (remove-identities1 stx) - [(~literal car) - #'(info #:in (Pairof out Any) #:in-∀ [] #:out out #:∀ [] - #:arg-funs [] #:funs [car])] - [(~literal cdr) - #'(info #:in (Pairof Any out) #:in-∀ [] #:out out #:∀ [] - #:arg-funs [] #:funs [cdr])] - ;; TODO: should remove `identity` completely, doing (map identity l) is - ;; useless appart for constraining the type, but it's an ugly way to do so. - [(~literal identity) - #'(info #:in out #:in-∀ [] #:out out #:∀ [] - #:arg-funs [] #:funs [identity])] - [((~literal compose) f …) - (syntax-parse (:map* #'(f …) #'(&l …) #'out #'[out-∀ …]) - [(~and (_ … rightmost:map-info) (leftmost:map-info . _) (:map-info …)) - #'(info #:in rightmost.in-type - #:in-∀ [rightmost.in-∀ …];; ?? - #:out leftmost.out-type - #:∀ [∀-type … …] - #:arg-funs [(arg-fun param-fun fun-in fun-out) … …] - #:funs [fun … …])])] - [((~literal curry) :mapp f) - (syntax-parse (internal-map: #'f #'(&l …) #'out #'[out-∀ …]) - [(i:map-info . code) - #`(info #:in (Listof i.in-type) - #:in-∀ [i.in-∀ …];; ?? - #:out (Listof out) - #:∀ [i.∀-type …]; i.out-type - #:arg-funs [(i.arg-fun i.param-fun i.fun-in i.fun-out) …] - #:funs [#,(syntax/loc #'f (code i.fun … _))])])] - [(~literal length) - (define-temp-ids "&~a" f) - (define-temp-ids "~a/in" f) - #'(info #:in f/in #:in-∀ [f/in] #:out out #:∀ [f/in] ;;?? - #:arg-funs [((λ ([l : (Listof Any)]) (length l)) - &f - #:auto-in f/in - out)] - #:funs [&f])] - [((~literal λget) pat …) - #'(info #:in (has-get out pat …) - #:in-∀ [out-∀ …] - #:out (result-get out pat …) - #:∀ [] - #:arg-funs [] - #:funs [(get _ pat …)])] - [f - (define-temp-ids "&~a" f) - (define-temp-ids "~a/in" f) - #'(info #:in f/in #:in-∀ [f/in] #:out out #:∀ [f/in] ;;?? - #:arg-funs [(f &f #:auto-in f/in out)] #:funs [&f])])) - -(define-syntax (apply-compose stx) +(define-type-expander (Deep-Listof stx) (syntax-parse stx - [(_ [] [a …]) - #'(values a …)] - [(_ [f … (~and loc (f-last x … (~literal _) y …))] [a …]) - #`(apply-compose [f …] [#,(syntax/loc #'loc (f-last x … a … y …))])] - [(_ [f … f-last] [a …]) - #`(apply-compose [f …] [#,(syntax/loc #'f-last (f-last a …))])])) + [(_ 0 T) + #'T] + [(_ d:>0 T) + #`(Listof (Deep-Listof #,(sub1 (syntax-e #'d)) T))])) -(define-for-syntax (internal-map: stx-f stx-&ls stx-out stx-out-∀) - (define/with-syntax f stx-f) - (define/with-syntax (&l …) stx-&ls) - (define/with-syntax out stx-out) - (define/with-syntax (out-∀ …) stx-out-∀) - (syntax-parse (:map #'f #'(&l …) #'out #'[out-∀ …]) - [(~and i :map-info) - (define/with-syntax map1 (generate-temporary #'map)) - (cons #'i - (template +(define-syntax (λdeep-map stx) + (syntax-parse stx + [(_ {∀-type:id …} A:expr B:expr 0) + #'(ann (λ (f x) (f x)) + (∀ (∀-type …) + (→ (→ A B) A B) + ;; Use the type below to allow identity functions, but it's more + ;; heavy on the typechecker + #;(case→ (→ (→ A B) A B) + (→ (→ A A) A A))))] + [(_ (~and norun #:norun) … {∀-type:id …} A:expr B:expr d:≥0) + (define/with-syntax local-map (generate-temporary #'map)) + #`(dbg norun … (let () - (: map1 (∀ [out-∀ … ∀-type …] - (→ (→ fun-in fun-out) … - (Listof in-type) - (Listof out-type)))) - (define (map1 param-fun … &l …) - (if (or (null? &l) …) + (: local-map + (∀ (∀-type …) + (→ (→ A B) (Deep-Listof d A) (Deep-Listof d B)) + ;; Use the type below to allow identity functions, but it's + ;; more heavy on the typechecker + #;(case→ (→ (→ A B) (Deep-Listof d A) (Deep-Listof d B)) + (→ (→ A A) (Deep-Listof d A) (Deep-Listof d A))))) + (define (local-map f l) + (if (null? l) '() - (cons (apply-compose [fun …] [(car &l) …]) - (map1 param-fun … (cdr &l) …)))) - map1)))]));(map1 arg-fun … . ls) + (cons ((λdeep-map {∀-type …} A B #,(sub1 (syntax-e #'d))) + f (car l)) + (local-map f (cdr l))))) + local-map))])) + +(module+ test + (check-equal?: ((λdeep-map {A B} A B 3) add1 '([{1} {2 3}] [{4}])) + : (Listof (Listof (Listof Number))) + '([{2} {3 4}] [{5}]))) + +(define-syntax (deep-map stx) + (syntax-parse stx + [(_ {∀-type:id …} A:expr B:expr d:≥0 f:expr l:expr) + (syntax/loc #'f ((λdeep-map {∀-type …} A B d) f l))])) + +(module+ test + (check-equal?: (deep-map {A B} A B 3 add1 '([{1} {2 3}] [{4}])) + : (Listof (Listof (Listof Number))) + '([{2} {3 4}] [{5}]))) + +(module+ test + (check-equal?: (deep-map {A B} A B 0 add1 '7) + : Number + 8)) + +;; We provide hints for the types of some common functions + +(define-type-expander (ArgOf stx) + (syntax-parse stx + [(_ (~literal length) T:expr R) #'(Listof Any)] + [(_ (~literal car) T:expr R) #'(Pairof T Any)] + [(_ (~literal car!) T:expr R) #'(U (Listof T) (Pairof T Any))] + [(_ (~literal cdr) T:expr R) #'(Pairof Any T)] + [(_ (~literal list) T:expr R) #'T] + [(_ ((~literal λget) f …) T:expr R) #'(has-get T f …)] + ;; Default case: + [(_ f:expr T:expr R) #'T])) + +(define-type-expander (ResultOf stx) + (syntax-parse stx + [(_ (~literal length) T:expr R) #'Index] + [(_ (~literal car) T:expr R) #'T] + [(_ (~literal car!) T:expr R) #'T] + [(_ (~literal cdr) T:expr R) #'T] + [(_ (~literal list) T:expr R) #'(List T)] + [(_ ((~literal λget) f …) T:expr R) #'(result-get T f …)] + ;; Default case: + [(_ f:expr T:expr R) #'R])) + +(define-syntax (substitute-function stx) + (syntax-parse stx + [(_ (~literal list)) #'(λ #:∀ (X) ([x : X]) : (List X) (list x))] + ;; Default case: + [(_ f:expr) #'f])) + +(define-syntax/parse (deep-map-auto d:≥0 f l) + #'(deep-map {A B} (ArgOf f A B) (ResultOf f A B) d (substitute-function f) l)) + +(module+ test + (check-equal?: (deep-map-auto 2 length '([{1} {2 3}] [{4}])) + : (Listof (Listof Index)) + '([1 2] [1]))) + +(module+ test + (check-equal?: (deep-map-auto 2 car '([{1} {2 3}] [{4}])) + : (Listof (Listof Number)) + '([1 2] [4]))) + +(module+ test + (check-equal?: (deep-map-auto 2 list '([1 2] [3])) + : (Listof (Listof (Listof Number))) + '([{1} {2}] [{3}]))) + +#;(module+ test + (check-equal?: (deep-map-auto 3 add1 (deep-map-auto 2 list '([1 2] [3]))) + : (Listof (Listof (Listof Number))) + '([{1} {2}] [{3}]))) + +(module+ test + (check-equal?: (deep-map-auto 1 length + (deep-map-auto 2 car + (deep-map-auto 2 list + '([1 2] [3])))) + : (Listof Index) + '(2 1))) + +;; Now we turn all map: calls into the form +;; (compose-maps [(d f) …] [l …]) + +(define-syntax (compose-maps stx) + (syntax-parse stx + [(_ [] [l]) + #'l] + [(_ [] [l:expr …]) + #'(values l …)] + [(_ [(d:≥0 f:expr) (d-rest:≥0 f-rest:expr) …] [l:expr …]) + #'(deep-map-auto d f (compose-maps [(d-rest f-rest) …] [l …]))])) + +(module+ test + (check-equal?: (compose-maps [(2 car!) (3 add1) (3 add1) (2 list)] + ['([1 2] [3])]) + : (Listof (Listof Number)) + '([3 4] [5]))) + +(define-for-syntax (transform-map: depth stx) + (syntax-parse stx + [((~literal curry) (~literal map) f:expr) + (transform-map: (add1 depth) #'f)] + [((~literal compose) f:expr …) + (define/syntax-parse (([dd ff] …) …) + (stx-map (curry transform-map: depth) #'(f …))) + #`[(dd ff) … …]] + [(~literal identity) #'[]] + [(~literal values) #'[]] + [f:expr + #`[(#,depth f)]])) -;; TODO: inefficient at compile-time: we run (:map #'f #'Out) twice. -;; Plus it could cause some bugs because of differing #'Out. (define-syntax (map: stx) (syntax-parse stx - [(_ (~optional (~and norun (~literal norun))) f l …) - (define-temp-ids "&~a" (l …)) - (syntax-parse (internal-map: #'f #'(&l …) #'Out #'[Out]) - [(:map-info . code) - (if (attribute norun) - #'(ann '(code arg-fun … l …) Any) - #'(code arg-fun … l …))])])) + [(_ f l) #`(compose-maps #,(transform-map: 1 #'f) [l])])) -(module* test typed/racket - (require (submod "..") - "../lib/low.rkt") +(module+ test + (check-equal?: (map: car '((1 a) (2 b) (3 c))) + : (Listof Number) + '(1 2 3))) + +(module+ test + (check-equal?: (map: (∘ (∘ add1) + length + (curry map car) + (curry map list) + (curry map (∘))) + '([1 2] [3])) + : (Listof Number) + '(3 2))) + +(module+ test + ;(require (submod "..") + ; "../lib/low.rkt") (check-equal?: (map: add1 '(1 2 3)) : (Listof Number) @@ -262,58 +270,59 @@ : (Listof (Listof Number)) '((2) (3) (4))) - ;; The tests below using (curry map: …) don't work, because typed/racket wraps - ;; the map: identifier with a contract, so the identifier seen outside the - ;; module is not the same as the one used in the syntax-parse ~literal clause. - - #|(begin - (check-equal?: (map: (curry map add1) '((1 2 3) (4 5))) + (begin + ;; Some of the tests below use (curry map: …), and don't work, because + ;; typed/racket wraps the map: identifier with a contract, so the identifier + ;; seen outside the module is not the same as the one used in the + ;; syntax-parse ~literal clause. + + (check-equal?: (map: (curry map add1) '((1 2 3) (4 5))) + : (Listof (Listof Number)) + '((2 3 4) (5 6))) + #;(check-equal?: (map: (curry map: add1) '((1 2 3) (4 5))) : (Listof (Listof Number)) '((2 3 4) (5 6))) - #;(check-equal?: (map: (curry map: add1) '((1 2 3) (4 5))) - : (Listof (Listof Number)) - '((2 3 4) (5 6))) - - (check-equal?: (map: (curry map (compose number->string add1)) + + (check-equal?: (map: (curry map (compose number->string add1)) + '((1 2 3) (4 5))) + : (Listof (Listof String)) + '(("2" "3" "4") ("5" "6"))) + #;(check-equal?: (map: (curry map: (compose number->string add1)) '((1 2 3) (4 5))) : (Listof (Listof String)) '(("2" "3" "4") ("5" "6"))) - #;(check-equal?: (map: (curry map: (compose number->string add1)) - '((1 2 3) (4 5))) - : (Listof (Listof String)) - '(("2" "3" "4") ("5" "6"))) - - (check-equal?: (map: add1 '(1 2 3)) - : (Listof Number) - '(2 3 4)) - - (check-equal?: (map: car '((1 a) (2 b) (3 c))) - : (Listof Number) - '(1 2 3)) - - (check-equal?: (map: (curry map car) '([{1 a} {2 b}] [{3 c}])) + + (check-equal?: (map: add1 '(1 2 3)) + : (Listof Number) + '(2 3 4)) + + (check-equal?: (map: car '((1 a) (2 b) (3 c))) + : (Listof Number) + '(1 2 3)) + + (check-equal?: (map: (curry map car) '([{1 a} {2 b}] [{3 c}])) + : (Listof (Listof Number)) + '([1 2] [3])) + #;(check-equal?: (map: (curry map: car) '([{1 a} {2 b}] [{3 c}])) : (Listof (Listof Number)) '([1 2] [3])) - #;(check-equal?: (map: (curry map: car) '([{1 a} {2 b}] [{3 c}])) - : (Listof (Listof Number)) - '([1 2] [3])) - - (check-equal?: (map: (curry map (curry map car)) + + (check-equal?: (map: (curry map (curry map car)) + '([((1 a) (2 b)) ((3 c))] [((4))])) + : (Listof (Listof (Listof Number))) + '([(1 2) (3)] [(4)])) + #;(check-equal?: (map: (curry map (curry map: car)) '([((1 a) (2 b)) ((3 c))] [((4))])) : (Listof (Listof (Listof Number))) '([(1 2) (3)] [(4)])) - #;(check-equal?: (map: (curry map (curry map: car)) - '([((1 a) (2 b)) ((3 c))] [((4))])) - : (Listof (Listof (Listof Number))) - '([(1 2) (3)] [(4)])) - #;(check-equal?: (map: (curry map: (curry map car)) - '([((1 a) (2 b)) ((3 c))] [((4))])) - : (Listof (Listof (Listof Number))) - '([(1 2) (3)] [(4)])) - #;(check-equal?: (map: (curry map: (curry map: car)) - '([((1 a) (2 b)) ((3 c))] [((4))])) - : (Listof (Listof (Listof Number))) - '([(1 2) (3)] [(4)])))|# + #;(check-equal?: (map: (curry map: (curry map car)) + '([((1 a) (2 b)) ((3 c))] [((4))])) + : (Listof (Listof (Listof Number))) + '([(1 2) (3)] [(4)])) + #;(check-equal?: (map: (curry map: (curry map: car)) + '([((1 a) (2 b)) ((3 c))] [((4))])) + : (Listof (Listof (Listof Number))) + '([(1 2) (3)] [(4)]))) (check-equal?: (map: car '((1 b x) (2 c) (3 d))) : (Listof Number) @@ -342,117 +351,4 @@ #| (check-equal?: (map: + '(1 2 3) '(4 5 6)) : (Listof Number) - '(5 7 9))|#) - - - - - - -#| -(map: (compose F (curry map add1)) '((1 2) (3))) - -Problem: in the code above, the input type of `F` has to be the return type of -`(curry map add1)`, i.e. `(Listof B)`. The return type of `F` may depend on its -input type (e.g. wrapping a value), so the type information flows leftwards -inside `compose`. - -However, if F is a destructuring operation, like `car` or `cdr`, it may impose -constraints on the return type of the function immediately to its right, meaning -that the type information flows rightwards. - -It seems difficult to reconcile these two cases without writing a complex -algorithm. - -Worst-case scenario: - - +-- constrains to the right - v v-- constrains to the right -(compose car complex-calculation (curry map car)) - ^ ^-- gives a (Listof ?) to the left - +-- constrained on both sides - -Maybe we could cover most common cases by first getting the type for the handled -cases which impose constraints to the right and/or give a type to the left, and -then use these types instead of the ∀, to fill in the holes for other functions. - -EDIT: that's what we did, using the #:auto-in -|# - - - - - - - - - - - - - - - - - - - -#| -(define-for-syntax (map-infer-types stx) - (syntax-parse stx - [(_ (~literal car)) - (values #'(A B) - #'(Pairof A B))] - [(_ (~literal cdr)) #'(Pairof Any T)] - [(_ T (~literal values)) #'T] - [(_ T ((~literal compose))) #'T] - [(_ T ((~literal compose) f0 . fs)) - #'(map-element (map-element T f0) (compose . fs))] - [(_ T ((~literal curry) (~or (~literal map:) (~literal map)) f) l) - #''_] - ;; get - [(_ f . ls) - ;; TODO: - #'T])) - -(define-type-expander (map-element stx) - (syntax-parse stx - [(_ T:id (~literal car)) #'(Pairof T Any)] - [(_ T:id (~literal cdr)) #'(Pairof Any T)] - [(_ T (~literal values)) #'T] - [(_ T ((~literal compose))) #'T] - [(_ T ((~literal compose) f0 . fs)) - #'(map-element (map-element T f0) (compose . fs))] - [(_ T ((~literal curry) (~or (~literal map:) (~literal map)) f) l) - #''_] - ;; get - [(_ f . ls) - ;; TODO: - #'T])) - - -(define-type-expander (map-result stx) - (syntax-parse stx - [(_ T:id (~literal car)) #'T] - [(_ T:id (~literal cdr)) #'T])) - -(define-syntax (map: stx) - (syntax-parse stx - [(_ (~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) (~or (~literal map:) (~literal map)) f) l) - #''_] - [(_ ((~literal λget) field-or-accessor …) l) - #'(get l (… …) field-or-accessor …)] - [(_ f . ls) - #'(map f . ls)])) - - - -|# - -;|# \ No newline at end of file + '(5 7 9))|#) \ No newline at end of file diff --git a/graph-lib/graph/map3.rkt b/graph-lib/graph/map3.rkt index b145432f..a3de16f4 100644 --- a/graph-lib/graph/map3.rkt +++ b/graph-lib/graph/map3.rkt @@ -6,7 +6,7 @@ syntax/parse/experimental/template "../lib/low-untyped.rkt") "../lib/low.rkt" - "graph4.lp2.rkt" + "get.lp2.rkt" "../type-expander/type-expander.lp2.rkt") ;; TODO: DEBUG diff --git a/graph-lib/graph/map4.rkt b/graph-lib/graph/map4.rkt deleted file mode 100644 index a92c48fc..00000000 --- a/graph-lib/graph/map4.rkt +++ /dev/null @@ -1,354 +0,0 @@ -#lang typed/racket - -(require (for-syntax racket/syntax - racket/function - syntax/stx - syntax/parse - "../lib/low-untyped.rkt") - "../lib/low.rkt" - "graph4.lp2.rkt" - "../type-expander/type-expander.lp2.rkt") - -(module m typed/racket - (provide car! cdr!) - - (: car! (∀ (A) (→ (U (Listof A) (Pairof A Any)) A))) - (define (car! x) (if (pair? x) - (car x) - (car x))) - - (: cdr! (∀ (A) (case→ (→ (Listof A) (Listof A)) - (→ (Pairof Any A) A)))) - (define (cdr! x) (cdr x))) - -(require 'm) -(provide (all-from-out 'm)) - -(provide map: compose-maps) - -(define-syntax (dbg stx) - (syntax-parse stx - [(_ (~optional (~and norun #:norun)) code) - (if (attribute norun) - #'(ann 'code Any) - #'code)])) - -(begin-for-syntax - (define-syntax-class >0 (pattern :exact-positive-integer))) - -(begin-for-syntax - (define-syntax-class ≥0 (pattern :exact-nonnegative-integer))) - -(define-type-expander (Deep-Listof stx) - (syntax-parse stx - [(_ 0 T) - #'T] - [(_ d:>0 T) - #`(Listof (Deep-Listof #,(sub1 (syntax-e #'d)) T))])) - -(define-syntax (λdeep-map stx) - (syntax-parse stx - [(_ {∀-type:id …} A:expr B:expr 0) - #'(ann (λ (f x) (f x)) - (∀ (∀-type …) - (→ (→ A B) A B) - ;; Use the type below to allow identity functions, but it's more - ;; heavy on the typechecker - #;(case→ (→ (→ A B) A B) - (→ (→ A A) A A))))] - [(_ (~and norun #:norun) … {∀-type:id …} A:expr B:expr d:≥0) - (define/with-syntax local-map (generate-temporary #'map)) - #`(dbg norun … - (let () - (: local-map - (∀ (∀-type …) - (→ (→ A B) (Deep-Listof d A) (Deep-Listof d B)) - ;; Use the type below to allow identity functions, but it's - ;; more heavy on the typechecker - #;(case→ (→ (→ A B) (Deep-Listof d A) (Deep-Listof d B)) - (→ (→ A A) (Deep-Listof d A) (Deep-Listof d A))))) - (define (local-map f l) - (if (null? l) - '() - (cons ((λdeep-map {∀-type …} A B #,(sub1 (syntax-e #'d))) - f (car l)) - (local-map f (cdr l))))) - local-map))])) - -(module+ test - (check-equal?: ((λdeep-map {A B} A B 3) add1 '([{1} {2 3}] [{4}])) - : (Listof (Listof (Listof Number))) - '([{2} {3 4}] [{5}]))) - -(define-syntax (deep-map stx) - (syntax-parse stx - [(_ {∀-type:id …} A:expr B:expr d:≥0 f:expr l:expr) - (syntax/loc #'f ((λdeep-map {∀-type …} A B d) f l))])) - -(module+ test - (check-equal?: (deep-map {A B} A B 3 add1 '([{1} {2 3}] [{4}])) - : (Listof (Listof (Listof Number))) - '([{2} {3 4}] [{5}]))) - -(module+ test - (check-equal?: (deep-map {A B} A B 0 add1 '7) - : Number - 8)) - -;; We provide hints for the types of some common functions - -(define-type-expander (ArgOf stx) - (syntax-parse stx - [(_ (~literal length) T:expr R) #'(Listof Any)] - [(_ (~literal car) T:expr R) #'(Pairof T Any)] - [(_ (~literal car!) T:expr R) #'(U (Listof T) (Pairof T Any))] - [(_ (~literal cdr) T:expr R) #'(Pairof Any T)] - [(_ (~literal list) T:expr R) #'T] - [(_ ((~literal λget) f …) T:expr R) #'(has-get T f …)] - ;; Default case: - [(_ f:expr T:expr R) #'T])) - -(define-type-expander (ResultOf stx) - (syntax-parse stx - [(_ (~literal length) T:expr R) #'Index] - [(_ (~literal car) T:expr R) #'T] - [(_ (~literal car!) T:expr R) #'T] - [(_ (~literal cdr) T:expr R) #'T] - [(_ (~literal list) T:expr R) #'(List T)] - [(_ ((~literal λget) f …) T:expr R) #'(result-get T f …)] - ;; Default case: - [(_ f:expr T:expr R) #'R])) - -(define-syntax (substitute-function stx) - (syntax-parse stx - [(_ (~literal list)) #'(λ #:∀ (X) ([x : X]) : (List X) (list x))] - ;; Default case: - [(_ f:expr) #'f])) - -(define-syntax/parse (deep-map-auto d:≥0 f l) - #'(deep-map {A B} (ArgOf f A B) (ResultOf f A B) d (substitute-function f) l)) - -(module+ test - (check-equal?: (deep-map-auto 2 length '([{1} {2 3}] [{4}])) - : (Listof (Listof Index)) - '([1 2] [1]))) - -(module+ test - (check-equal?: (deep-map-auto 2 car '([{1} {2 3}] [{4}])) - : (Listof (Listof Number)) - '([1 2] [4]))) - -(module+ test - (check-equal?: (deep-map-auto 2 list '([1 2] [3])) - : (Listof (Listof (Listof Number))) - '([{1} {2}] [{3}]))) - -#;(module+ test - (check-equal?: (deep-map-auto 3 add1 (deep-map-auto 2 list '([1 2] [3]))) - : (Listof (Listof (Listof Number))) - '([{1} {2}] [{3}]))) - -(module+ test - (check-equal?: (deep-map-auto 1 length - (deep-map-auto 2 car - (deep-map-auto 2 list - '([1 2] [3])))) - : (Listof Index) - '(2 1))) - -;; Now we turn all map: calls into the form -;; (compose-maps [(d f) …] [l …]) - -(define-syntax (compose-maps stx) - (syntax-parse stx - [(_ [] [l]) - #'l] - [(_ [] [l:expr …]) - #'(values l …)] - [(_ [(d:≥0 f:expr) (d-rest:≥0 f-rest:expr) …] [l:expr …]) - #'(deep-map-auto d f (compose-maps [(d-rest f-rest) …] [l …]))])) - -(module+ test - (check-equal?: (compose-maps [(2 car!) (3 add1) (3 add1) (2 list)] - ['([1 2] [3])]) - : (Listof (Listof Number)) - '([3 4] [5]))) - -(define-for-syntax (transform-map: depth stx) - (syntax-parse stx - [((~literal curry) (~literal map) f:expr) - (transform-map: (add1 depth) #'f)] - [((~literal compose) f:expr …) - (define/syntax-parse (([dd ff] …) …) - (stx-map (curry transform-map: depth) #'(f …))) - #`[(dd ff) … …]] - [(~literal identity) #'[]] - [(~literal values) #'[]] - [f:expr - #`[(#,depth f)]])) - -(define-syntax (map: stx) - (syntax-parse stx - [(_ f l) #`(compose-maps #,(transform-map: 1 #'f) [l])])) - -(module+ test - (check-equal?: (map: car '((1 a) (2 b) (3 c))) - : (Listof Number) - '(1 2 3))) - -(module+ test - (check-equal?: (map: (∘ (∘ add1) - length - (curry map car) - (curry map list) - (curry map (∘))) - '([1 2] [3])) - : (Listof Number) - '(3 2))) - -(module+ test - ;(require (submod "..") - ; "../lib/low.rkt") - - (check-equal?: (map: add1 '(1 2 3)) - : (Listof Number) - '(2 3 4)) - (check-equal?: (map: (compose add1) '(1 2 3)) - : (Listof Number) - '(2 3 4)) - (check-equal?: (map: (∘ identity add1) '(1 2 3)) - : (Listof Number) - '(2 3 4)) - (check-equal?: (map: (∘ add1 identity) '(1 2 3)) - : (Listof Number) - '(2 3 4)) - (check-equal?: (map: (∘ number->string add1) '(1 2 9)) - : (Listof String) - '("2" "3" "10")) - (check-equal?: (map: (∘ string-length number->string add1) '(1 2 9)) - : (Listof Number) - '(1 1 2)) - (check-equal?: (map: car '((1 2) (2) (9 10 11))) - : (Listof Number) - '(1 2 9)) - (check-equal?: (map: (∘ add1 car) '((1 2) (2) (9 10 11))) - : (Listof Number) - '(2 3 10)) - (check-equal?: (map: (∘ string-length number->string add1 car cdr) - '((1 2) (2 3) (8 9 10))) - : (Listof Number) - '(1 1 2)) - (check-equal?: (map: identity '(1 2 3)) - : (Listof Number) - '(1 2 3)) - (check-equal?: (map: values '(1 2 3)) - : (Listof Number) - '(1 2 3)) - (check-equal?: (map: (compose) '(1 2 3)) - : (Listof Number) - '(1 2 3)) - (check-equal?: (map: (compose identity) '(1 2 3)) - : (Listof Number) - '(1 2 3)) - (check-equal?: (map: (∘ identity values identity values) '(1 2 3)) - : (Listof Number) - '(1 2 3)) - (check-equal?: (map: (∘ length (curry map add1)) '((1 2) (3))) - : (Listof Number) - '(2 1)) - (check-equal?: (map: (curry map add1) '((1 2) (3))) - : (Listof (Listof Number)) - '((2 3) (4))) - - (define (numlist [x : Number]) (list x)) - (check-equal?: (map: (∘ (curry map add1) numlist) '(1 2 3)) - : (Listof (Listof Number)) - '((2) (3) (4))) - - (check-equal?: (map: (∘ (curry map add1) (λ ([x : Number]) (list x))) - '(1 2 3)) - : (Listof (Listof Number)) - '((2) (3) (4))) - - (begin - ;; Some of the tests below use (curry map: …), and don't work, because - ;; typed/racket wraps the map: identifier with a contract, so the identifier - ;; seen outside the module is not the same as the one used in the - ;; syntax-parse ~literal clause. - - (check-equal?: (map: (curry map add1) '((1 2 3) (4 5))) - : (Listof (Listof Number)) - '((2 3 4) (5 6))) - #;(check-equal?: (map: (curry map: add1) '((1 2 3) (4 5))) - : (Listof (Listof Number)) - '((2 3 4) (5 6))) - - (check-equal?: (map: (curry map (compose number->string add1)) - '((1 2 3) (4 5))) - : (Listof (Listof String)) - '(("2" "3" "4") ("5" "6"))) - #;(check-equal?: (map: (curry map: (compose number->string add1)) - '((1 2 3) (4 5))) - : (Listof (Listof String)) - '(("2" "3" "4") ("5" "6"))) - - (check-equal?: (map: add1 '(1 2 3)) - : (Listof Number) - '(2 3 4)) - - (check-equal?: (map: car '((1 a) (2 b) (3 c))) - : (Listof Number) - '(1 2 3)) - - (check-equal?: (map: (curry map car) '([{1 a} {2 b}] [{3 c}])) - : (Listof (Listof Number)) - '([1 2] [3])) - #;(check-equal?: (map: (curry map: car) '([{1 a} {2 b}] [{3 c}])) - : (Listof (Listof Number)) - '([1 2] [3])) - - (check-equal?: (map: (curry map (curry map car)) - '([((1 a) (2 b)) ((3 c))] [((4))])) - : (Listof (Listof (Listof Number))) - '([(1 2) (3)] [(4)])) - #;(check-equal?: (map: (curry map (curry map: car)) - '([((1 a) (2 b)) ((3 c))] [((4))])) - : (Listof (Listof (Listof Number))) - '([(1 2) (3)] [(4)])) - #;(check-equal?: (map: (curry map: (curry map car)) - '([((1 a) (2 b)) ((3 c))] [((4))])) - : (Listof (Listof (Listof Number))) - '([(1 2) (3)] [(4)])) - #;(check-equal?: (map: (curry map: (curry map: car)) - '([((1 a) (2 b)) ((3 c))] [((4))])) - : (Listof (Listof (Listof Number))) - '([(1 2) (3)] [(4)]))) - - (check-equal?: (map: car '((1 b x) (2 c) (3 d))) - : (Listof Number) - '(1 2 3)) - (check-equal?: (map: cdr '((1 b x) (2 c) (3 d))) - : (Listof (Listof Symbol)) - '((b x) (c) (d))) - (check-equal?: (map: car (map: cdr '((1 b x) (2 c) (3 d)))) - : (Listof Symbol) - '(b c d)) - (check-equal?: (map: (compose) '((1 b x) (2 c) (3 d))) - : (Listof (Listof (U Number Symbol))) - '((1 b x) (2 c) (3 d))) - (check-equal?: (map: (compose car) '((1 b x) (2 c) (3 d))) - : (Listof Number) - '(1 2 3)) - (check-equal?: (map: (compose cdr) '((1 b x) (2 c) (3 d))) - : (Listof (Listof Symbol)) - '((b x) (c) (d))) - (check-equal?: (map: (compose car cdr) '((1 b x) (2 c) (3 d))) - : (Listof Symbol) - '(b c d)) - (check-equal?: (map: (compose add1 car) '((1 b x) (2 c) (3 d))) - : (Listof Number) - '(2 3 4)) - #| - (check-equal?: (map: + '(1 2 3) '(4 5 6)) - : (Listof Number) - '(5 7 9))|#) \ No newline at end of file diff --git a/graph-lib/graph/map_old.rkt b/graph-lib/graph/map_old.rkt new file mode 100644 index 00000000..a244e1f2 --- /dev/null +++ b/graph-lib/graph/map_old.rkt @@ -0,0 +1,458 @@ +#lang debug typed/racket + +(require (for-syntax racket/syntax + syntax/stx + syntax/parse + syntax/parse/experimental/template + "../lib/low-untyped.rkt") + (for-meta 2 + racket/base + racket/syntax) + "../lib/low.rkt" + "map1.rkt" + "get.lp2.rkt" + "../type-expander/type-expander.lp2.rkt") + +(provide map: apply-compose) ;; TODO: move apply-compose to lib/low.rkt + +(begin-for-syntax + (define-syntax-class lam + (pattern (~or (~literal λ) (~literal lambda)))) + (define-syntax-class mapp + (pattern (~or (~literal map) (~literal map:))))) + +(define-for-syntax (remove-identities stx) + (syntax-parse stx + [() #'()] + [((~or (~lit identity) (~lit values) (~lit compose)) . rest) + (remove-identities #'rest)] + [([(~literal compose) . fs] . rest) + (define/with-syntax cleaned-fs (remove-identities #'fs)) + (syntax-parse #'cleaned-fs + [() (remove-identities #'rest)] + [(one-f) #`(one-f . #,(remove-identities #'rest))] + [some-fs #`((compose . some-fs) . #,(remove-identities #'rest))])] + [(f . rest) + #`(f . #,(remove-identities #'rest))])) + +;; TODO: check that we don't bork the literals identity, values and compose +;; inside macros or function calls, or alter them in any other way, e.g. +;; (map: (compose identity (λ (values) (+ values 1)) identity) '(1 2 3)) +;; or +;; (define (calltwice f) (λ (x) (f (f x)))) +;; (map: (compose (calltwice identity)) '(1 2 3)) +;; Although a poor variable name choice, the two occurences of "values" in the +;; first example shouldn't be altered, and the λ itself shouldn't be touched. +;; In the second one, everything inside the calltwice function call should be +;; left intact. +(define-for-syntax (remove-identities1 stx) + (syntax-parse (remove-identities #`(#,stx)) + [() #'identity] + [(f) #'f])) + +(begin-for-syntax + (define-syntax-class map-info + (pattern (_ #:in in-type + #:in-∀ [in-∀ …] + #:out out-type + #:∀ (∀-type …) + #:arg-funs ([arg-fun + param-fun + (~optional (~and auto-in #:auto-in)) + fun-in fun-out] …) + #:funs [fun …])))) + +(begin-for-syntax + (define-syntax (mk-info stx) + (syntax-case stx () + [(_ . rest-stx) + (begin + (define/with-syntax whole-stx (syntax/loc stx (info . rest-stx))) + #'(syntax-parse #`whole-stx + [i:map-info #'i]))]))) + +(define-for-syntax (:map* stx* stx-&ls stx-out stx-out-∀) + (if (stx-null? stx*) + '() + (syntax-parse (:map (stx-car stx*) stx-&ls stx-out stx-out-∀) + [info:map-info + (let ([r (:map* (stx-cdr stx*) stx-&ls #'info.in-type #'[info.in-∀ …])] + [auto (attribute info.auto-in)]) + (if (and (not (null? auto)) (car auto) (not (null? r))) + (syntax-parse (car r) + [r-info:map-info + (let ([intact #'([info.arg-fun + info.param-fun + info.fun-in ;;; + info.fun-out] …)] + [replaced #'([info.arg-fun + info.param-fun + r-info.out-type ;;info.fun-in ;;; + info.fun-out] …)]) + (cons (mk-info #:in info.in-type + #:in-∀ [info.in-∀ …] + #:out info.out-type + #:∀ (info.∀-type …) + #:arg-funs (#,(stx-car replaced) + #,@(stx-cdr intact)) + #:funs [info.fun …]) + r))]) + (cons #'info r)))]))) + +(define-for-syntax (:map stx stx-&ls stx-out stx-out-∀) + (define/with-syntax (&l …) stx-&ls) + (define/with-syntax out stx-out) + (define/with-syntax (out-∀ …) stx-out-∀) + (syntax-parse (remove-identities1 stx) + [(~literal car) + #'(info #:in (Pairof out Any) #:in-∀ [] #:out out #:∀ [] + #:arg-funs [] #:funs [car])] + [(~literal cdr) + #'(info #:in (Pairof Any out) #:in-∀ [] #:out out #:∀ [] + #:arg-funs [] #:funs [cdr])] + ;; TODO: should remove `identity` completely, doing (map identity l) is + ;; useless appart for constraining the type, but it's an ugly way to do so. + [(~literal identity) + #'(info #:in out #:in-∀ [] #:out out #:∀ [] + #:arg-funs [] #:funs [identity])] + [((~literal compose) f …) + (syntax-parse (:map* #'(f …) #'(&l …) #'out #'[out-∀ …]) + [(~and (_ … rightmost:map-info) (leftmost:map-info . _) (:map-info …)) + #'(info #:in rightmost.in-type + #:in-∀ [rightmost.in-∀ …];; ?? + #:out leftmost.out-type + #:∀ [∀-type … …] + #:arg-funs [(arg-fun param-fun fun-in fun-out) … …] + #:funs [fun … …])])] + [((~literal curry) :mapp f) + (syntax-parse (internal-map: #'f #'(&l …) #'out #'[out-∀ …]) + [(i:map-info . code) + #`(info #:in (Listof i.in-type) + #:in-∀ [i.in-∀ …];; ?? + #:out (Listof out) + #:∀ [i.∀-type …]; i.out-type + #:arg-funs [(i.arg-fun i.param-fun i.fun-in i.fun-out) …] + #:funs [#,(syntax/loc #'f (code i.fun … _))])])] + [(~literal length) + (define-temp-ids "&~a" f) + (define-temp-ids "~a/in" f) + #'(info #:in f/in #:in-∀ [f/in] #:out out #:∀ [f/in] ;;?? + #:arg-funs [((λ ([l : (Listof Any)]) (length l)) + &f + #:auto-in f/in + out)] + #:funs [&f])] + [((~literal λget) pat …) + #'(info #:in (has-get out pat …) + #:in-∀ [out-∀ …] + #:out (result-get out pat …) + #:∀ [] + #:arg-funs [] + #:funs [(get _ pat …)])] + [f + (define-temp-ids "&~a" f) + (define-temp-ids "~a/in" f) + #'(info #:in f/in #:in-∀ [f/in] #:out out #:∀ [f/in] ;;?? + #:arg-funs [(f &f #:auto-in f/in out)] #:funs [&f])])) + +(define-syntax (apply-compose stx) + (syntax-parse stx + [(_ [] [a …]) + #'(values a …)] + [(_ [f … (~and loc (f-last x … (~literal _) y …))] [a …]) + #`(apply-compose [f …] [#,(syntax/loc #'loc (f-last x … a … y …))])] + [(_ [f … f-last] [a …]) + #`(apply-compose [f …] [#,(syntax/loc #'f-last (f-last a …))])])) + +(define-for-syntax (internal-map: stx-f stx-&ls stx-out stx-out-∀) + (define/with-syntax f stx-f) + (define/with-syntax (&l …) stx-&ls) + (define/with-syntax out stx-out) + (define/with-syntax (out-∀ …) stx-out-∀) + (syntax-parse (:map #'f #'(&l …) #'out #'[out-∀ …]) + [(~and i :map-info) + (define/with-syntax map1 (generate-temporary #'map)) + (cons #'i + (template + (let () + (: map1 (∀ [out-∀ … ∀-type …] + (→ (→ fun-in fun-out) … + (Listof in-type) + (Listof out-type)))) + (define (map1 param-fun … &l …) + (if (or (null? &l) …) + '() + (cons (apply-compose [fun …] [(car &l) …]) + (map1 param-fun … (cdr &l) …)))) + map1)))]));(map1 arg-fun … . ls) + +;; TODO: inefficient at compile-time: we run (:map #'f #'Out) twice. +;; Plus it could cause some bugs because of differing #'Out. +(define-syntax (map: stx) + (syntax-parse stx + [(_ (~optional (~and norun (~literal norun))) f l …) + (define-temp-ids "&~a" (l …)) + (syntax-parse (internal-map: #'f #'(&l …) #'Out #'[Out]) + [(:map-info . code) + (if (attribute norun) + #'(ann '(code arg-fun … l …) Any) + #'(code arg-fun … l …))])])) + +(module* test typed/racket + (require (submod "..") + "../lib/low.rkt") + + (check-equal?: (map: add1 '(1 2 3)) + : (Listof Number) + '(2 3 4)) + (check-equal?: (map: (compose add1) '(1 2 3)) + : (Listof Number) + '(2 3 4)) + (check-equal?: (map: (∘ identity add1) '(1 2 3)) + : (Listof Number) + '(2 3 4)) + (check-equal?: (map: (∘ add1 identity) '(1 2 3)) + : (Listof Number) + '(2 3 4)) + (check-equal?: (map: (∘ number->string add1) '(1 2 9)) + : (Listof String) + '("2" "3" "10")) + (check-equal?: (map: (∘ string-length number->string add1) '(1 2 9)) + : (Listof Number) + '(1 1 2)) + (check-equal?: (map: car '((1 2) (2) (9 10 11))) + : (Listof Number) + '(1 2 9)) + (check-equal?: (map: (∘ add1 car) '((1 2) (2) (9 10 11))) + : (Listof Number) + '(2 3 10)) + (check-equal?: (map: (∘ string-length number->string add1 car cdr) + '((1 2) (2 3) (8 9 10))) + : (Listof Number) + '(1 1 2)) + (check-equal?: (map: identity '(1 2 3)) + : (Listof Number) + '(1 2 3)) + (check-equal?: (map: values '(1 2 3)) + : (Listof Number) + '(1 2 3)) + (check-equal?: (map: (compose) '(1 2 3)) + : (Listof Number) + '(1 2 3)) + (check-equal?: (map: (compose identity) '(1 2 3)) + : (Listof Number) + '(1 2 3)) + (check-equal?: (map: (∘ identity values identity values) '(1 2 3)) + : (Listof Number) + '(1 2 3)) + (check-equal?: (map: (∘ length (curry map add1)) '((1 2) (3))) + : (Listof Number) + '(2 1)) + (check-equal?: (map: (curry map add1) '((1 2) (3))) + : (Listof (Listof Number)) + '((2 3) (4))) + + (define (numlist [x : Number]) (list x)) + (check-equal?: (map: (∘ (curry map add1) numlist) '(1 2 3)) + : (Listof (Listof Number)) + '((2) (3) (4))) + + (check-equal?: (map: (∘ (curry map add1) (λ ([x : Number]) (list x))) + '(1 2 3)) + : (Listof (Listof Number)) + '((2) (3) (4))) + + ;; The tests below using (curry map: …) don't work, because typed/racket wraps + ;; the map: identifier with a contract, so the identifier seen outside the + ;; module is not the same as the one used in the syntax-parse ~literal clause. + + #|(begin + (check-equal?: (map: (curry map add1) '((1 2 3) (4 5))) + : (Listof (Listof Number)) + '((2 3 4) (5 6))) + #;(check-equal?: (map: (curry map: add1) '((1 2 3) (4 5))) + : (Listof (Listof Number)) + '((2 3 4) (5 6))) + + (check-equal?: (map: (curry map (compose number->string add1)) + '((1 2 3) (4 5))) + : (Listof (Listof String)) + '(("2" "3" "4") ("5" "6"))) + #;(check-equal?: (map: (curry map: (compose number->string add1)) + '((1 2 3) (4 5))) + : (Listof (Listof String)) + '(("2" "3" "4") ("5" "6"))) + + (check-equal?: (map: add1 '(1 2 3)) + : (Listof Number) + '(2 3 4)) + + (check-equal?: (map: car '((1 a) (2 b) (3 c))) + : (Listof Number) + '(1 2 3)) + + (check-equal?: (map: (curry map car) '([{1 a} {2 b}] [{3 c}])) + : (Listof (Listof Number)) + '([1 2] [3])) + #;(check-equal?: (map: (curry map: car) '([{1 a} {2 b}] [{3 c}])) + : (Listof (Listof Number)) + '([1 2] [3])) + + (check-equal?: (map: (curry map (curry map car)) + '([((1 a) (2 b)) ((3 c))] [((4))])) + : (Listof (Listof (Listof Number))) + '([(1 2) (3)] [(4)])) + #;(check-equal?: (map: (curry map (curry map: car)) + '([((1 a) (2 b)) ((3 c))] [((4))])) + : (Listof (Listof (Listof Number))) + '([(1 2) (3)] [(4)])) + #;(check-equal?: (map: (curry map: (curry map car)) + '([((1 a) (2 b)) ((3 c))] [((4))])) + : (Listof (Listof (Listof Number))) + '([(1 2) (3)] [(4)])) + #;(check-equal?: (map: (curry map: (curry map: car)) + '([((1 a) (2 b)) ((3 c))] [((4))])) + : (Listof (Listof (Listof Number))) + '([(1 2) (3)] [(4)])))|# + + (check-equal?: (map: car '((1 b x) (2 c) (3 d))) + : (Listof Number) + '(1 2 3)) + (check-equal?: (map: cdr '((1 b x) (2 c) (3 d))) + : (Listof (Listof Symbol)) + '((b x) (c) (d))) + (check-equal?: (map: car (map: cdr '((1 b x) (2 c) (3 d)))) + : (Listof Symbol) + '(b c d)) + (check-equal?: (map: (compose) '((1 b x) (2 c) (3 d))) + : (Listof (Listof (U Number Symbol))) + '((1 b x) (2 c) (3 d))) + (check-equal?: (map: (compose car) '((1 b x) (2 c) (3 d))) + : (Listof Number) + '(1 2 3)) + (check-equal?: (map: (compose cdr) '((1 b x) (2 c) (3 d))) + : (Listof (Listof Symbol)) + '((b x) (c) (d))) + (check-equal?: (map: (compose car cdr) '((1 b x) (2 c) (3 d))) + : (Listof Symbol) + '(b c d)) + (check-equal?: (map: (compose add1 car) '((1 b x) (2 c) (3 d))) + : (Listof Number) + '(2 3 4)) + #| + (check-equal?: (map: + '(1 2 3) '(4 5 6)) + : (Listof Number) + '(5 7 9))|#) + + + + + + +#| +(map: (compose F (curry map add1)) '((1 2) (3))) + +Problem: in the code above, the input type of `F` has to be the return type of +`(curry map add1)`, i.e. `(Listof B)`. The return type of `F` may depend on its +input type (e.g. wrapping a value), so the type information flows leftwards +inside `compose`. + +However, if F is a destructuring operation, like `car` or `cdr`, it may impose +constraints on the return type of the function immediately to its right, meaning +that the type information flows rightwards. + +It seems difficult to reconcile these two cases without writing a complex +algorithm. + +Worst-case scenario: + + +-- constrains to the right + v v-- constrains to the right +(compose car complex-calculation (curry map car)) + ^ ^-- gives a (Listof ?) to the left + +-- constrained on both sides + +Maybe we could cover most common cases by first getting the type for the handled +cases which impose constraints to the right and/or give a type to the left, and +then use these types instead of the ∀, to fill in the holes for other functions. + +EDIT: that's what we did, using the #:auto-in +|# + + + + + + + + + + + + + + + + + + + +#| +(define-for-syntax (map-infer-types stx) + (syntax-parse stx + [(_ (~literal car)) + (values #'(A B) + #'(Pairof A B))] + [(_ (~literal cdr)) #'(Pairof Any T)] + [(_ T (~literal values)) #'T] + [(_ T ((~literal compose))) #'T] + [(_ T ((~literal compose) f0 . fs)) + #'(map-element (map-element T f0) (compose . fs))] + [(_ T ((~literal curry) (~or (~literal map:) (~literal map)) f) l) + #''_] + ;; get + [(_ f . ls) + ;; TODO: + #'T])) + +(define-type-expander (map-element stx) + (syntax-parse stx + [(_ T:id (~literal car)) #'(Pairof T Any)] + [(_ T:id (~literal cdr)) #'(Pairof Any T)] + [(_ T (~literal values)) #'T] + [(_ T ((~literal compose))) #'T] + [(_ T ((~literal compose) f0 . fs)) + #'(map-element (map-element T f0) (compose . fs))] + [(_ T ((~literal curry) (~or (~literal map:) (~literal map)) f) l) + #''_] + ;; get + [(_ f . ls) + ;; TODO: + #'T])) + + +(define-type-expander (map-result stx) + (syntax-parse stx + [(_ T:id (~literal car)) #'T] + [(_ T:id (~literal cdr)) #'T])) + +(define-syntax (map: stx) + (syntax-parse stx + [(_ (~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) (~or (~literal map:) (~literal map)) f) l) + #''_] + [(_ ((~literal λget) field-or-accessor …) l) + #'(get l (… …) field-or-accessor …)] + [(_ f . ls) + #'(map f . ls)])) + + + +|# + +;|# \ No newline at end of file diff --git a/graph-lib/graph/test-map4-get.rkt b/graph-lib/graph/test-map-get.rkt similarity index 91% rename from graph-lib/graph/test-map4-get.rkt rename to graph-lib/graph/test-map-get.rkt index 69c349d6..619b2c74 100644 --- a/graph-lib/graph/test-map4-get.rkt +++ b/graph-lib/graph/test-map-get.rkt @@ -1,9 +1,9 @@ #lang typed/racket (module test typed/racket - (require (submod "graph3.lp2.rkt" test)) - (require "graph4.lp2.rkt") - (require "map4.rkt") + (require (submod "graph.lp2.rkt" test)) + (require "get.lp2.rkt") + (require "map.rkt") (require "structure.lp2.rkt") (require "variant.lp2.rkt") (require "../lib/low.rkt") diff --git a/graph-lib/lib.rkt b/graph-lib/lib.rkt new file mode 100644 index 00000000..eb8aa5c4 --- /dev/null +++ b/graph-lib/lib.rkt @@ -0,0 +1,23 @@ +#lang typed/racket + +(require racket/require) + +(define-syntax-rule (r/p . mods) + (begin + (require . mods) + (provide (all-from-out . mods)))) + +(r/p "lib/low.rkt" + "type-expander/multi-id.lp2.rkt" + "type-expander/type-expander.lp2.rkt" + "graph/structure.lp2.rkt" + "graph/variant.lp2.rkt" + "graph/graph.lp2.rkt" + "graph/get.lp2.rkt" + "graph/map.rkt" + #|"graph/rewrite-type.lp2.rkt"|#) + +(require (subtract-in "graph/dotlang.rkt" + "type-expander/type-expander.lp2.rkt")) + +(provide (all-from-out "graph/dotlang.rkt")) diff --git a/graph-lib/main.rkt b/graph-lib/main.rkt index 7c772652..05ca1c0d 100644 --- a/graph-lib/main.rkt +++ b/graph-lib/main.rkt @@ -1,11 +1,13 @@ -#lang typed/racket +#lang s-exp "lib.rkt" -(require (submod "graph/test-map4-get.rkt" test)) +#| +(require (submod "graph/test-map-get.rkt" test)) (require (submod "graph/dotlang.rkt" test)) (require "type-expander/type-expander.lp2.rkt") (require "type-expander/multi-id.lp2.rkt") (require "graph/variant.lp2.rkt") +|# (define-type from (List (Pairof Number Boolean) (Listof (U Number (Pairof Number String)))))