Renamed files, added lib.rkt (FB case 69).
This commit is contained in:
Georges Dupéron
parent
d6c6f86544
commit
4cceadc84e
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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[<example-variants>
|
||||
[City [streets : (Listof Street)] [people : (Listof Person)] <m-city>]
|
||||
[Street [sname : String] [houses : (Listof House)] <m-street>]
|
||||
[House [owner : Person] [location : Street] <m-house>]
|
||||
[Person [name : String] <m-person>]]
|
||||
|
||||
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[<example-root>
|
||||
'(["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>
|
||||
[(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>
|
||||
[(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>
|
||||
[(m-house [s : String]
|
||||
[c : (Listof (Pairof String String))]
|
||||
[p : String])
|
||||
(House (m-person p) (m-street c s))]]
|
||||
|
||||
@chunk[<m-person>
|
||||
[(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[<use-example>
|
||||
(define-graph make-g <example-variants>)
|
||||
#;(define g (make-g <example-root>))
|
||||
(define g1 (make-g <example-root>))
|
||||
(define g g1)]
|
||||
|
||||
@subsection{More details on the semantics}
|
||||
|
||||
Let's take a second look at the root mapping:
|
||||
|
||||
@chunk[<m-city-2>
|
||||
[(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[<signature>
|
||||
(define-graph name
|
||||
[node <field-signature> … <mapping-declaration>]
|
||||
…)]
|
||||
|
||||
Where @tc[<field-signature>] is:
|
||||
|
||||
@chunk[<field-signature>
|
||||
[field:id :colon field-type:expr]]
|
||||
|
||||
And @tc[<mapping-declaration>] is:
|
||||
|
||||
@chunk[<mapping-declaration>
|
||||
((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-ids>
|
||||
(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[<fold-queue-type-element>
|
||||
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[<fold-queue-type-result>
|
||||
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>
|
||||
(fold-queues <root-placeholder>
|
||||
[(node/placeholder-queue [e : <fold-queue-type-element>]
|
||||
[Δ-queues : Δ-Queues]
|
||||
enqueue)
|
||||
: <fold-queue-type-result>
|
||||
<fold-queue-body>]
|
||||
...)]
|
||||
|
||||
@subsection{Making placeholders for nodes}
|
||||
|
||||
We start creating the root placeholder which we provide to @tc[fold-queues].
|
||||
|
||||
@chunk[<root-placeholder>
|
||||
(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-placeholder-type>
|
||||
(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[<define-make-placeholder>
|
||||
(: 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-with-indices>
|
||||
(define-type node/index-type (List 'node/with-indices-tag2 Index))
|
||||
|
||||
(define-type node/with-indices-type
|
||||
(List 'node/with-indices-tag <field/with-indices-type> …))
|
||||
|
||||
(: node/make-with-indices (→ <field/with-indices-type> …
|
||||
node/with-indices-type))
|
||||
(define (node/make-with-indices field …)
|
||||
(list 'node/with-indices-tag field …))]
|
||||
|
||||
@CHUNK[<field/with-indices-type>
|
||||
(tmpl-replace-in-type field-type [node node/index-type] …)]
|
||||
|
||||
@subsection{Making with-promises nodes}
|
||||
|
||||
We derive the @tc[with-promises] type from each @emph{ideal} node type using
|
||||
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-with-promises>
|
||||
|
||||
(define-type node/with-promises-type
|
||||
(tagged node/with-promises-tag
|
||||
[field : <field/with-promises-type>] …))
|
||||
|
||||
(: node/make-with-promises (→ <field/with-promises-type> …
|
||||
node/with-promises-type))
|
||||
(define (node/make-with-promises field/value …)
|
||||
(tagged node/with-promises-tag
|
||||
[field : <field/with-promises-type> field/value]
|
||||
…))]
|
||||
|
||||
@CHUNK[<field/with-promises-type>
|
||||
(tmpl-replace-in-type field-type
|
||||
[node (Promise node/with-promises-type)] …)]
|
||||
|
||||
@subsection{Making incomplete nodes}
|
||||
|
||||
We derive the @tc[incomplete] type from each @emph{ideal} node type using
|
||||
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-incomplete>
|
||||
(define-type node/incomplete-type
|
||||
(List 'node/incomplete-tag <field/incomplete-type> …))
|
||||
|
||||
(: node/make-incomplete (→ <field/incomplete-type> …
|
||||
node/incomplete-type))
|
||||
(define (node/make-incomplete field …)
|
||||
(list 'node/incomplete-tag field …))]
|
||||
|
||||
@CHUNK[<field/incomplete-type>
|
||||
(tmpl-replace-in-type field-type
|
||||
[node node/placeholder-type] …)]
|
||||
|
||||
@subsection{Converting incomplete nodes to with-indices ones}
|
||||
|
||||
@; TODO: we don't need that many annotations
|
||||
@chunk[<placeholder→with-indices-function>
|
||||
(λ ([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[<placeholder→with-indices-clause>
|
||||
[node/placeholder-type
|
||||
(List 'node/with-indices-tag2 Index)
|
||||
(λ (x) (and (pair? x)
|
||||
(eq? (car x) 'node/placeholder-tag)))
|
||||
<placeholder→with-indices-function>]]
|
||||
|
||||
@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[<fold-queue-body>
|
||||
(let ([mapping-result (apply node/mapping-function (cdr e))])
|
||||
(let ([f (tmpl-fold-instance (List <field-incomplete-type> …)
|
||||
Δ-Queues
|
||||
<placeholder→with-indices-clause> …)])
|
||||
(let-values ([(r new-Δ-queues) (f (cdr mapping-result) Δ-queues)])
|
||||
(values (cons 'node/with-indices-tag r)
|
||||
new-Δ-queues))))]
|
||||
|
||||
Where @tc[<field-incomplete-type>] is the @tc[field-type] in which node types
|
||||
are replaced by placeholder types:
|
||||
|
||||
@chunk[<field-incomplete-type>
|
||||
(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[<define-mapping-function>
|
||||
(: 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[<index→promise-clause>
|
||||
[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 <index→promise> 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[<index→promise>
|
||||
(let ([successor-with-index (vector-ref node/database
|
||||
(cadr tagged-index))])
|
||||
(delay (node/with-indices→with-promises successor-with-index)))]
|
||||
|
||||
@chunk[<define-with-indices→with-promises>
|
||||
(: 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 <field-with-indices-type> …)
|
||||
Void
|
||||
<index→promise-clause> …))
|
||||
(apply node/make-with-promises (first-value (f (cdr n) (void)))))]
|
||||
|
||||
Where @tc[<field-with-indices-type>] is the @tc[field-type] in which node types
|
||||
are replaced by tagged indices:
|
||||
|
||||
@chunk[<field-with-indices-type>
|
||||
(tmpl-replace-in-type field-type [node node/index-type] …)]
|
||||
|
||||
@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
@comment[#|
|
||||
@subsection{Converting incomplete nodes to with-promises ones}
|
||||
|
||||
@chunk[<convert-incomplete-to-with-promises>
|
||||
[node/incomplete-type
|
||||
node/with-promises-type
|
||||
(λ (x) (and (pair? x) (eq? (car x) 'node/incomplete-tag)))
|
||||
(λ ([x : node/incomplete-type] [acc : Void])
|
||||
<convert-incomplete-successor>)]]
|
||||
|
||||
@chunk[<convert-placeholder-to-with-promises>
|
||||
[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])
|
||||
<convert-placeholder-successor>)]]
|
||||
|
||||
@; TODO: this would be much simpler if we forced having only one mapping per
|
||||
@; node, and extended that with a macro.
|
||||
|
||||
@chunk[<define-compatible-mappings>
|
||||
(define/with-syntax ((node/compatible-mappings ...) ...)
|
||||
(for/list ([x (in-syntax #'(node ...))])
|
||||
(multiassoc-syntax
|
||||
x
|
||||
#'([result-type . mapping]
|
||||
…))))]
|
||||
|
||||
@chunk[<convert-incomplete-successor>
|
||||
(error (~a "Not implemented yet " x))]
|
||||
|
||||
@chunk[<convert-placeholder-successor>
|
||||
(% 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-graph>
|
||||
(define-syntax/parse <signature>
|
||||
<define-ids>
|
||||
#|((λ (x) (pretty-write (syntax->datum x)) x)|#
|
||||
(template
|
||||
;(let ()
|
||||
(begin
|
||||
(begin <define-placeholder-type>) …
|
||||
(begin <define-make-placeholder>) …
|
||||
(begin <define-with-indices>) …
|
||||
(begin <define-with-promises>) …
|
||||
(begin <define-incomplete>) …
|
||||
(begin <define-mapping-function>) …
|
||||
|
||||
(: name (→ root-param-type … (Promise root/with-promises-type)))
|
||||
(define (name root-param …)
|
||||
(match-let ([(list node/database …) <fold-queues>])
|
||||
(begin <define-with-indices→with-promises>) …
|
||||
(let ([root/with-promises (root/with-indices→with-promises
|
||||
(vector-ref root/database 0))])
|
||||
(delay root/with-promises)))))))]
|
||||
|
||||
@chunk[<module-main>
|
||||
(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
|
||||
;<multiassoc-syntax>)
|
||||
|
||||
(provide define-graph)
|
||||
<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>
|
||||
(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)
|
||||
<use-example>)]
|
||||
|
||||
The whole file, finally:
|
||||
|
||||
@chunk[<*>
|
||||
(begin
|
||||
<module-main>
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
||||
<module-test>)]
|
||||
884
graph-lib/graph/graph_old.lp2.rkt
Normal file
884
graph-lib/graph/graph_old.lp2.rkt
Normal file
|
|
@ -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[<example-1674389-2>
|
||||
(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[<example-1674389>
|
||||
(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[<example-1674389-2>
|
||||
(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[<make-graph-constructor>
|
||||
(define-syntax/parse
|
||||
(make-graph-constructor ([node (field:id field-type:expr) ...] ...)
|
||||
[transform:id (param:id param-type:expr) ...
|
||||
(~literal :) result-type:id
|
||||
body ...]
|
||||
...)
|
||||
<stx-transform/link-request>
|
||||
<stx-make-graph-database>
|
||||
<stx-node/incomplete>
|
||||
<stx-param-type/old>
|
||||
<stx-transform/result-node/extract-link-requests>
|
||||
<stx-transform/link-request→incomplete>
|
||||
#`(let ()
|
||||
<param-type/old>
|
||||
(let ()
|
||||
<define-incomplete-types>
|
||||
<define-make-link-requests>
|
||||
<transform/link-request→incomplete>
|
||||
<define-transforms>
|
||||
<make-graph-database>
|
||||
make-graph-database)))]
|
||||
|
||||
@chunk[<test-make-graph-constructor>
|
||||
(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[<stx-param-type/old>
|
||||
(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[<param-type/old>
|
||||
(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[<stx-node/incomplete>
|
||||
(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[<stx-node/incomplete>
|
||||
(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[<stx-node/incomplete>
|
||||
(define/with-syntax (transform/result-node/incomplete ...)
|
||||
(for/list ([x (in-syntax #'(result-type ...))])
|
||||
(assoc-syntax x #'([node . node/incomplete] ...))))]
|
||||
|
||||
@CHUNK[<define-incomplete-types>
|
||||
(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[<stx-transform/link-request>
|
||||
(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[<pre-declare-transform/link-request>
|
||||
(struct (TKey)
|
||||
transform/link-request-pre-declared
|
||||
([key : TKey])
|
||||
#:transparent)]
|
||||
|
||||
@chunk[<define-make-link-requests>
|
||||
(define-type transform/link-request
|
||||
(transform/link-request-pre-declared
|
||||
(List 'transform
|
||||
param-type/old ...)))
|
||||
...]
|
||||
|
||||
@subsection{Transforms}
|
||||
|
||||
@chunk[<stx-transform/link-request→incomplete>
|
||||
(define/with-syntax (transform/link-request→incomplete ...)
|
||||
(format-temp-ids "~a/link-request→incomplete" #'(transform ...)))]
|
||||
|
||||
@chunk[<transform/link-request→incomplete>
|
||||
(begin
|
||||
(: transform/link-request→incomplete
|
||||
(→ param-type/old ... transform/result-node/incomplete))
|
||||
(define (transform/link-request→incomplete param ...)
|
||||
body ...))
|
||||
...]
|
||||
|
||||
@chunk[<define-transforms>
|
||||
(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[<stx-make-graph-database>
|
||||
(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 ...)))
|
||||
<fold-type-clauses>
|
||||
<fold-type-stx>
|
||||
<stx-extract-link-requests>]
|
||||
|
||||
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>
|
||||
(: 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[<make-graph-database>
|
||||
(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
|
||||
...)
|
||||
<define-extract-link-requests> ;; TODO: Can probably be moved out.
|
||||
<process-queue-body>)
|
||||
|
||||
<process-queue-initial-call>)]
|
||||
|
||||
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-initial-call>
|
||||
(process-queue (set (root-transform root-transform/param ...))
|
||||
(set)
|
||||
(begin 'transform/transformed '())
|
||||
...)]
|
||||
|
||||
Process-queue is a standard queue handler using sets.
|
||||
|
||||
@CHUNK[<process-queue-body>
|
||||
(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))])
|
||||
<process-queue-body-tags>))]
|
||||
|
||||
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[<process-queue-body-tags>
|
||||
(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[<fold-type-match-example>
|
||||
(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[<fold-type-clauses>
|
||||
(define (fold-type-clauses val t)
|
||||
(syntax-parse t
|
||||
<fold-type-clauses-body>))]
|
||||
|
||||
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[<fold-type-clauses-body>
|
||||
[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[<fold-type-clauses-body>
|
||||
[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[<fold-type-clauses-body>
|
||||
[((~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[<fold-type-clauses-body>
|
||||
[((~literal Listof) a)
|
||||
#`([(list tmp (... ...))
|
||||
(append-map (λ (tmp1) #,(fold-type #'tmp1 #'a))
|
||||
tmp)])]]
|
||||
|
||||
Pairs and vectors are handled similarly:
|
||||
|
||||
@CHUNK[<fold-type-clauses-body>
|
||||
[((~literal Pairof) a b)
|
||||
#`([(cons tmpa tmpb)
|
||||
(list #,(fold-type #'tmpa #'a)
|
||||
#,(fold-type #'tmpb #'b))])]]
|
||||
|
||||
@CHUNK[<fold-type-clauses-body>
|
||||
[((~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[<fold-type-clauses-body>
|
||||
[((~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[<stx-transform/result-node/extract-link-requests>
|
||||
(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[<fold-type-clauses-body>
|
||||
[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[<fold-type-stx>
|
||||
(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[<stx-extract-link-requests>
|
||||
(define-template-metafunction (fold-type-tmpl stx)
|
||||
(syntax-case stx () [(_ val t) (fold-type #'val #'t)]))]
|
||||
@CHUNK[<define-extract-link-requests>
|
||||
#,@(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[<fold-type-cases>
|
||||
[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[<outermost-incomplete>
|
||||
(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[<save-outer-incomplete>
|
||||
(define-type-expander (outer-incomplete stx)
|
||||
(syntax-case stx () [(_ n) #'(incomplete n)]))]
|
||||
|
||||
@chunk[<incomplete>
|
||||
(let ()
|
||||
<save-outer-incomplete>
|
||||
(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)]))
|
||||
<body>))]
|
||||
|
||||
@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[<substitute-link-requests>
|
||||
(define (substitute-link-requests v)
|
||||
(match v
|
||||
[(node/incomplete field ...)
|
||||
(node <link-request→promise> ...)]
|
||||
...))]
|
||||
|
||||
@chunk[<link-request→promise>
|
||||
(match field
|
||||
[(transform/link-request key _) (transform/key→promise key)] ;; TODO
|
||||
...)]
|
||||
|
||||
@chunk[<transform/key→promise>
|
||||
]
|
||||
|
||||
@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[<attempt-at-typing-traverse>
|
||||
(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[<fold-type-cases2>
|
||||
[(~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[<traverse-list-type>
|
||||
(→ (List a ...) (List replaced-a ...))]
|
||||
|
||||
@chunk[<traverse-list-code>
|
||||
[(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[<fold-type-cases2>
|
||||
[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[<fold-check-no-link-requests>
|
||||
(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[<multiassoc-syntax>
|
||||
(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[<old-make-graph-database>
|
||||
;; 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[<test-graph>
|
||||
(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
|
||||
<multiassoc-syntax>)
|
||||
<pre-declare-transform/link-request>
|
||||
|
||||
<make-graph-constructor>
|
||||
|
||||
#|<graph>|#)
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../lib/test-framework.rkt")
|
||||
|
||||
;; Debug
|
||||
<pre-declare-transform/link-request>
|
||||
(require syntax/parse
|
||||
"../lib/low.rkt"
|
||||
"structure.lp2.rkt"
|
||||
"variant.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
;;
|
||||
|
||||
<test-graph>
|
||||
<test-make-graph-constructor>))]
|
||||
|
|
@ -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)]))
|
||||
|
||||
|
||||
|
||||
|#
|
||||
|
||||
;|#
|
||||
'(5 7 9))|#)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))|#)
|
||||
458
graph-lib/graph/map_old.rkt
Normal file
458
graph-lib/graph/map_old.rkt
Normal file
|
|
@ -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)]))
|
||||
|
||||
|
||||
|
||||
|#
|
||||
|
||||
;|#
|
||||
|
|
@ -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")
|
||||
23
graph-lib/lib.rkt
Normal file
23
graph-lib/lib.rkt
Normal file
|
|
@ -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"))
|
||||
|
|
@ -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)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user