Split library into many smaller files.
This commit is contained in:
Georges Dupéron
parent
2d1ef94acf
commit
a91cc950cd
|
|
@ -1,618 +0,0 @@
|
|||
#lang debug scribble/lp2
|
||||
@(require "../lib/doc.rkt")
|
||||
@doc-lib-setup
|
||||
|
||||
@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 show 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 variants:
|
||||
|
||||
@chunk[<example-variants>
|
||||
[City [streets : (Listof Street)] [people : (Listof Person)] <m-city>]
|
||||
[Street [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 . 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 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 mappings that will
|
||||
create other 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] mapping and
|
||||
the @tc[Person] node constructor.
|
||||
|
||||
@; Would be nicer with (map (∘ (curry street c) my-car) c)), but that doesn't
|
||||
@; typecheck (yet).
|
||||
@chunk[<m-city>
|
||||
[(m-city [c : (Listof (Pairof String String))]) : City
|
||||
(City (remove-duplicates (map (curry m-street c) (cars c)))
|
||||
(remove-duplicates (map m-person (cdrs 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
|
||||
(Street (map (curry (curry m-house s) c)
|
||||
(cars (filter (λ ([x : (Pairof String String)])
|
||||
(equal? (cdr x) s))
|
||||
c))))]]
|
||||
|
||||
The @tc[m-house] mapping 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 the @tc[m-street] function here 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[make-graph-constructor] 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.
|
||||
|
||||
Finally, we write the @tc[m-house] mapping.
|
||||
|
||||
@chunk[<m-house>
|
||||
[(m-house [s : String]
|
||||
[c : (Listof (Pairof String String))]
|
||||
[p : String])
|
||||
: House
|
||||
(House (m-person p) (m-street c s))]]
|
||||
|
||||
@chunk[<m-person>
|
||||
[(m-person [p : String]) : Person
|
||||
(Person p)]]
|
||||
|
||||
@identity{
|
||||
Notice how we are calling directly the @tc[Person] constructor above. We also
|
||||
called it directly in the @tc[m-city] mapping. Since @tc[Person] does not
|
||||
contain references to @tc[House], @tc[Street] or @tc[City], we do not need to
|
||||
delay creation of these nodes by calling yet another mapping.
|
||||
|
||||
@; TODO: above: Should we merge two identical instances of Person? They won't
|
||||
@; necessarily be eq? if they contain cycles deeper in their structure, anyway.
|
||||
@; And we are already merging all equal? placeholders, so there shouldn't be
|
||||
@; any blowup in the number of nodes.
|
||||
@; It would probably be better for graph-map etc. to have all the nodes in the
|
||||
@; database, though.
|
||||
|
||||
The number and names of mappings do not necessarily reflect the graph's type.
|
||||
Here, we have no mapping named @tc[m-person], because that node is always
|
||||
created directly. Conversely, we could have two mappings, @tc[m-big-street] and
|
||||
@tc[m-small-street], with different behaviours, instead of passing an extra
|
||||
boolean argument to @tc[m-street].
|
||||
|
||||
@; TODO: make the two street mappings
|
||||
}
|
||||
|
||||
@subsubsection{Making a constructor for the graph}
|
||||
|
||||
@identity{
|
||||
@chunk[<make-constructor-example>
|
||||
(make-graph-constructor (<example-variants>)
|
||||
<example-root>)]
|
||||
|
||||
@subsubsection{Creating a graph instance}
|
||||
|
||||
@chunk[<use-example>
|
||||
(define g <make-constructor-example>)]
|
||||
}
|
||||
|
||||
@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
|
||||
(City (remove-duplicates (map (curry m-street c) (cars c)))
|
||||
(remove-duplicates (map Person (cdrs c))))]]
|
||||
|
||||
The first case shows that 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.
|
||||
|
||||
@identity{
|
||||
The second case shows that we can also directly call the constructor for the
|
||||
@tc[Person] node type. If that type contains references to other nodes, the
|
||||
constructor here will actually accept either a placeholder, or an actual
|
||||
instance, which itself may contain placeholders.
|
||||
|
||||
The node type allowing placeholders is derived from the ideal type given above.
|
||||
Here, the type for @tc[Person] is @tc[[String]], so there are no substitutions
|
||||
to make. On the contrary, the type for @tc[City], originally expressed as
|
||||
@tc[[(Listof Street) (Listof Person)]], will be rewritten into
|
||||
@tc[[(Listof (U Street Street-Placeholder))
|
||||
(Listof (U Person Person-Placeholder))]].
|
||||
}
|
||||
|
||||
The @tc[rewrite-type] module we use to derive types with placeholders from the
|
||||
original 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[make-graph-constructor] macro is
|
||||
implemented.
|
||||
|
||||
@subsection{The macro's syntax}
|
||||
|
||||
We use a simple syntax for @tc[make-graph-constructor], and make it more
|
||||
flexible through wrapper macros.
|
||||
|
||||
@chunk[<signature>
|
||||
(make-graph-constructor
|
||||
(root-expr:expr ...)
|
||||
([node <field-signature> … <mapping-declaration>] …))]
|
||||
|
||||
Where @tc[<field-signature>] is:
|
||||
|
||||
@chunk[<field-signature>
|
||||
[field-name:id (~literal :) field-type:expr]]
|
||||
|
||||
And @tc[<mapping-declaration>] is:
|
||||
|
||||
@chunk[<mapping-declaration>
|
||||
((mapping:id [param:id (~literal :) param-type:expr] …)
|
||||
. mapping-body)]
|
||||
|
||||
@subsection{The different types of a node and mapping}
|
||||
|
||||
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 (Pairof 'Street/with-indices-tag Index))
|
||||
(Listof (Pairof 'Person/with-indices-tag 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 (this is the code directly provided by the user)}]
|
||||
|
||||
We derive identifiers for these based on the @tc[node] or @tc[mapping] name:
|
||||
|
||||
@;;;;
|
||||
@chunk[<define-ids2>
|
||||
(define-temp-ids "~a/make-placeholder" (mapping …) #:first-base root)
|
||||
(define-temp-ids "~a/placeholder-type" (mapping …))
|
||||
(define-temp-ids "~a/make-incomplete" (node …))
|
||||
(define-temp-ids "~a/incomplete-type" (node …))
|
||||
(define-temp-ids "~a/make-with-indices" (node …))
|
||||
(define-temp-ids "~a/with-indices-type" (node …))
|
||||
(define-temp-ids "~a/make-with-promises" (node …))
|
||||
(define-temp-ids "~a/with-promises-type" (node …))
|
||||
(define-temp-ids "~a/function" (mapping …))]
|
||||
|
||||
@chunk[<define-ids2>
|
||||
(define/with-syntax (root/make-placeholder . _)
|
||||
#'(mapping/make-placeholder …))]
|
||||
|
||||
@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 in 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 new
|
||||
ones as these 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
|
||||
queues' element types will therefore be these placeholder types.
|
||||
|
||||
@chunk[<fold-queue-type-element>
|
||||
mapping/placeholder-type]
|
||||
|
||||
The return type for each queue will be the corresponding with-promises type. The
|
||||
fold-queues function will therefore return a vector of with-promises nodes.
|
||||
|
||||
@chunk[<fold-queue-type-result>
|
||||
<with-promises-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-queus 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)]. 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
|
||||
the latest @tc[Δ-queues] in order to have these elements added to the queue.
|
||||
|
||||
@chunk[<fold-queue>
|
||||
(fold-queues <root-placeholder>
|
||||
[(mapping/placeholder-tag [e : <fold-queue-type-element>]
|
||||
Δ-queues
|
||||
enqueue)
|
||||
: <fold-queue-type-result>
|
||||
<fold-queue-body>]
|
||||
...)]
|
||||
|
||||
@subsection{Making placeholders for mappings}
|
||||
|
||||
We start creating the root placeholder which we provide to @tc[fold-queues].
|
||||
|
||||
@chunk[<root-placeholder>
|
||||
(root/make-placeholder root-expr ...)]
|
||||
|
||||
To make the placeholder, we will need a @tc[make-placeholder] function for each
|
||||
@tc[mapping]. We define the type of each placeholder (a list of arguments,
|
||||
tagged with the @tc[mapping]'s name), and a constructor:
|
||||
|
||||
@; TODO: just use (variant [mapping param-type ...] ...)
|
||||
|
||||
@chunk[<define-mapping-placeholder>
|
||||
(define-type mapping/placeholder-type (List 'mapping/placeholder-tag
|
||||
param-type ...))
|
||||
|
||||
(: mapping/make-placeholder (→ param-type ... mapping/placeholder-type))
|
||||
(define (mapping/make-placeholder [param : param-type] ...)
|
||||
(list 'mapping/placeholder-tag param ...))]
|
||||
|
||||
The code above needs some identifiers derived from @tc[mapping] names:
|
||||
|
||||
@chunk[<define-ids>
|
||||
(define-temp-ids "~a/make-placeholder" (mapping ...))
|
||||
(define-temp-ids "~a/placeholder-type" (mapping ...))
|
||||
(define-temp-ids "~a/placeholder-tag" (mapping ...))
|
||||
(define/with-syntax (root/make-placeholder . _)
|
||||
#'(mapping/make-placeholder ...))]
|
||||
|
||||
@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-nodes>
|
||||
(define-type field/with-promises-type
|
||||
(tmpl-replace-in-type field-type
|
||||
[node (Promise node/with-promises-type)]
|
||||
…))
|
||||
…
|
||||
|
||||
(define-type node/with-promises-type (List 'with-promises
|
||||
'node
|
||||
field/with-promises-type …))
|
||||
|
||||
(: node/make-with-promises (→ field/with-promises-type …
|
||||
node/with-promises-type))
|
||||
(define (node/make-with-promises field-name …)
|
||||
(list 'with-promises 'node field-name …))]
|
||||
|
||||
The code above needs some identifiers derived from @tc[node] and
|
||||
@tc[field-name]s:
|
||||
|
||||
@chunk[<define-ids>
|
||||
(define-temp-ids "~a/make-with-promises" (node ...))
|
||||
(define-temp-ids "~a/with-promises-type" (node ...))
|
||||
(define/with-syntax ((field/with-promises-type …) …)
|
||||
(stx-map generate-temporaries #'((field-name …) …)))]
|
||||
|
||||
@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 a union of the
|
||||
node's @tc[incomplete] type, and all compatible @tc[placeholder] types.
|
||||
|
||||
TODO: for now we allow all possible mappings, but we should only allow those
|
||||
which return type is the desired node type.
|
||||
|
||||
@; TODO: use a type-expander here, instead of a template metafunction.
|
||||
|
||||
@CHUNK[<define-incomplete-nodes>
|
||||
(define-type field/incomplete-type <field/incomplete-type>)
|
||||
…
|
||||
|
||||
(define-type node/incomplete-type
|
||||
(Pairof 'node/incomplete-tag (List field/incomplete-type …)))
|
||||
|
||||
(: node/make-incomplete (→ field/incomplete-type … node/incomplete-type))
|
||||
(define (node/make-incomplete field-name …)
|
||||
(list 'node/incomplete-tag field-name …))]
|
||||
|
||||
Since the incomplete type for fields will appear in two different places, above
|
||||
and in the incomplete-to-with-promises conversion routine below, we write it in
|
||||
a separate chunk:
|
||||
|
||||
@chunk[<field/incomplete-type>
|
||||
(tmpl-replace-in-type field-type
|
||||
[node (U node/incomplete-type
|
||||
node/compatible-placeholder-types …)]
|
||||
…)]
|
||||
|
||||
@identity{
|
||||
We must however compute for each node the set of compatible placeholder types.
|
||||
We do that
|
||||
|
||||
@chunk[<define-compatible-placeholder-types>
|
||||
(define/with-syntax ((node/compatible-placeholder-types ...) ...)
|
||||
(for/list ([x (in-syntax #'(node ...))])
|
||||
(multiassoc-syntax
|
||||
x
|
||||
#'([result-type . mapping/placeholder-type];;;;;;;;;;;;;;;;;;;;;;;;;;;; . (List 'mapping/placeholder-tag param-type ...)
|
||||
…))))]
|
||||
|
||||
The multiassoc-syntax function used above filters the associative syntax list
|
||||
and returns the @tc[stx-cdr] of the matching elements, therefore returning a
|
||||
list of @tc[mapping/placeholder-type]s for which the @tc[result-type] is the
|
||||
given @tc[node] name.
|
||||
|
||||
@chunk[<multiassoc-syntax>
|
||||
(define (multiassoc-syntax query alist)
|
||||
(map stx-cdr
|
||||
(filter (λ (xy) (free-identifier=? query (stx-car xy)))
|
||||
(syntax->list alist))))
|
||||
|
||||
(define (cdr-assoc-syntax query alist)
|
||||
(stx-cdr (findf (λ (xy) (free-identifier=? query (stx-car xy)))
|
||||
(syntax->list alist))))
|
||||
|
||||
(define-template-metafunction (tmpl-cdr-assoc-syntax stx)
|
||||
(syntax-parse stx
|
||||
[(_ query [k . v] …)
|
||||
(cdr-assoc-syntax #'query #'([k . v] …))]))]
|
||||
|
||||
The code above also needs some identifiers derived from @tc[node] and
|
||||
@tc[field-name]s:
|
||||
|
||||
@chunk[<define-ids>
|
||||
(define-temp-ids "~a/make-incomplete" (node …))
|
||||
(define-temp-ids "~a/incomplete-type" (node …))
|
||||
(define-temp-ids "~a/incomplete-tag" (node …))
|
||||
(define-temp-ids "~a/incomplete-fields" (node …))
|
||||
(define/with-syntax ((field/incomplete-type …) …)
|
||||
(stx-map-nested #'((field-name …) …)))]
|
||||
}
|
||||
|
||||
@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)))]
|
||||
|
||||
|
||||
@subsection{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?
|
||||
|
||||
@CHUNK[<fold-queue-body>
|
||||
(let ([mapping-result (apply mapping/function (cdr e))])
|
||||
(tmpl-fold-instance <the-incomplete-type>
|
||||
Void
|
||||
<convert-incomplete-to-with-promises> …
|
||||
<convert-placeholder-to-with-promises> …))
|
||||
'todo!]
|
||||
|
||||
@chunk[<the-incomplete-type>
|
||||
(tmpl-cdr-assoc-syntax result-type
|
||||
[node . (List <field/incomplete-type> …)]
|
||||
…)]
|
||||
|
||||
@section{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 incomplete node type.
|
||||
|
||||
@chunk[<define-mapping-function>
|
||||
(define-type mapping/incomplete-result-type
|
||||
(tmpl-replace-in-type result-type
|
||||
[node (List 'node/incomplete-tag
|
||||
<field/incomplete-type> …)]
|
||||
…))
|
||||
|
||||
(: mapping/function (→ param-type … mapping/incomplete-result-type))
|
||||
(define mapping/function
|
||||
(let ([mapping mapping/make-placeholder]
|
||||
…
|
||||
[node node/make-incomplete]
|
||||
…)
|
||||
(λ (param …)
|
||||
. mapping-body)))]
|
||||
|
||||
@chunk[<define-ids>
|
||||
(define-temp-ids "~a/function" (mapping ...))
|
||||
(define-temp-ids "~a/incomplete-result-type" (mapping ...))]
|
||||
|
||||
@section{Temporary fillers}
|
||||
|
||||
@chunk[<with-promises-type>
|
||||
Any]
|
||||
|
||||
|
||||
@section{Putting it all together}
|
||||
|
||||
@chunk[<make-graph-constructor>
|
||||
(define-syntax/parse <signature>
|
||||
<define-ids>
|
||||
(let ()
|
||||
<define-ids2>
|
||||
<define-compatible-placeholder-types>
|
||||
((λ (x) (pretty-write (syntax->datum x)) x)
|
||||
(template
|
||||
(let ()
|
||||
(begin <define-mapping-placeholder>) …
|
||||
(begin <define-with-promises-nodes>) …
|
||||
(begin <define-incomplete-nodes>) …
|
||||
(begin <define-mapping-function>) …
|
||||
<fold-queue>)))))]
|
||||
|
||||
@section{Conclusion}
|
||||
|
||||
@chunk[<module-main>
|
||||
(module main typed/racket
|
||||
(require (for-syntax syntax/parse
|
||||
racket/syntax
|
||||
syntax/stx
|
||||
syntax/parse/experimental/template
|
||||
racket/sequence
|
||||
racket/pretty; DEBUG
|
||||
alexis/util/threading; DEBUG
|
||||
"rewrite-type.lp2.rkt"
|
||||
"../lib/low-untyped.rkt")
|
||||
alexis/util/threading; DEBUG
|
||||
"fold-queues.lp2.rkt"
|
||||
"rewrite-type.lp2.rkt"
|
||||
"../lib/low.rkt")
|
||||
|
||||
(begin-for-syntax
|
||||
<multiassoc-syntax>)
|
||||
|
||||
(provide make-graph-constructor)
|
||||
<make-graph-constructor>)]
|
||||
|
||||
@chunk[<module-test>
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
"fold-queues.lp2.rkt"; DEBUG
|
||||
"rewrite-type.lp2.rkt"; DEBUG
|
||||
"../lib/low.rkt"; DEBUG
|
||||
typed/rackunit)
|
||||
|
||||
<use-example>
|
||||
|
||||
g)]
|
||||
|
||||
@chunk[<*>
|
||||
(begin
|
||||
<module-main>
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
||||
<module-test>)]
|
||||
File diff suppressed because it is too large
Load Diff
18
graph-lib/lib/low/aliases.rkt
Normal file
18
graph-lib/lib/low/aliases.rkt
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide ∘ … …+)
|
||||
|
||||
(require (only-in racket
|
||||
[compose ∘]
|
||||
[... …])
|
||||
(only-in syntax/parse
|
||||
[...+ …+]))
|
||||
|
||||
(require racket/match)
|
||||
(provide (all-from-out racket/match)
|
||||
(rename-out [match-lambda match-λ]
|
||||
[match-lambda* match-λ*]
|
||||
[match-lambda** match-λ**]))
|
||||
|
||||
(require/typed racket/syntax [generate-temporary (→ Any Identifier)]))
|
||||
19
graph-lib/lib/low/cond-let.rkt
Normal file
19
graph-lib/lib/low/cond-let.rkt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide cond-let)
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
(submod "aliases.rkt" untyped)))
|
||||
|
||||
(define-syntax (cond-let stx)
|
||||
(syntax-parse stx
|
||||
[(_)
|
||||
#'(typecheck-fail #,stx)]
|
||||
[(_ #:let bindings:expr clause …)
|
||||
#'(let bindings (cond-let clause …))]
|
||||
[(_ [condition:expr (~seq #:else-let binding …) … . body] clause …)
|
||||
#'(if condition
|
||||
(begin . body)
|
||||
(let (binding … …)
|
||||
(cond-let clause …)))])))
|
||||
20
graph-lib/lib/low/fixnum.rkt
Normal file
20
graph-lib/lib/low/fixnum.rkt
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide fxxor)
|
||||
|
||||
;; For fxxor, used to compute hashes.
|
||||
;; The type obtained just by writing (require racket/fixnum) is wrong, so we
|
||||
;; get a more precise one.
|
||||
(require/typed racket/fixnum [(fxxor fxxor2) (→ Fixnum Fixnum Fixnum)])
|
||||
|
||||
(: fxxor (→ Fixnum * Fixnum))
|
||||
(define (fxxor . args)
|
||||
(foldl fxxor2 0 args))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (fxxor2 13206 23715) 28469)
|
||||
(check-equal? (fxxor 0) 0)
|
||||
(check-equal? (fxxor 13206) 13206)
|
||||
(check-equal? (fxxor 13206 23715 314576) 304101)))
|
||||
23
graph-lib/lib/low/generate-indices.rkt
Normal file
23
graph-lib/lib/low/generate-indices.rkt
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide generate-indices)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
(require-typed/untyped "sequence.rkt")
|
||||
(: generate-indices (∀ (T) (case→ (→ Integer (Syntax-Listof T)
|
||||
(Listof Integer))
|
||||
(→ (Syntax-Listof T)
|
||||
(Listof Nonnegative-Integer)))))
|
||||
|
||||
(define generate-indices
|
||||
(case-lambda
|
||||
[(start stx)
|
||||
(for/list ([v (my-in-syntax stx)]
|
||||
[i (in-naturals start)])
|
||||
i)]
|
||||
[(stx)
|
||||
(for/list ([v (my-in-syntax stx)]
|
||||
[i : Nonnegative-Integer
|
||||
(ann (in-naturals) (Sequenceof Nonnegative-Integer))])
|
||||
i)])))
|
||||
308
graph-lib/lib/low/ids.rkt
Normal file
308
graph-lib/lib/low/ids.rkt
Normal file
|
|
@ -0,0 +1,308 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:untyped-first
|
||||
(provide !temp
|
||||
(rename-out [!temp &])
|
||||
format-ids
|
||||
hyphen-ids
|
||||
format-temp-ids
|
||||
#|!temp|#
|
||||
define-temp-ids)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
(require-typed/untyped "sequence.rkt")
|
||||
|
||||
|
||||
|
||||
(module m-!temp racket
|
||||
(provide !temp)
|
||||
|
||||
(require syntax/parse
|
||||
syntax/parse/experimental/template)
|
||||
|
||||
(define-template-metafunction (!temp stx)
|
||||
(syntax-parse stx
|
||||
[(_ id:id)
|
||||
#:with (temp) (generate-temporaries #'(id))
|
||||
#'temp]
|
||||
#|[(_ . id:id)
|
||||
#:with (temp) (generate-temporaries #'(id))
|
||||
#'temp]
|
||||
[(_ id:id ...)
|
||||
(generate-temporaries #'(id ...))]|#)))
|
||||
(require 'm-!temp)
|
||||
|
||||
(require/typed racket/syntax
|
||||
[format-id (→ Syntax String (U String Identifier) *
|
||||
Identifier)]
|
||||
[(generate-temporary generate-temporary2) (→ Any Identifier)])
|
||||
(require (only-in racket/syntax define/with-syntax)
|
||||
(only-in syntax/stx stx-map)
|
||||
(for-syntax racket/base
|
||||
racket/syntax
|
||||
syntax/parse
|
||||
syntax/parse/experimental/template))
|
||||
;(require racket/sequence) ;; in-syntax
|
||||
|
||||
(define-type S-Id-List
|
||||
(U String
|
||||
Identifier
|
||||
(Listof String)
|
||||
(Listof Identifier)
|
||||
(Syntaxof (Listof Identifier))))
|
||||
|
||||
; TODO: format-ids doesn't accept arbitrary values. Should we change it?
|
||||
;
|
||||
(: format-ids (→ (U Syntax (→ (U String Identifier) * Syntax))
|
||||
String
|
||||
S-Id-List *
|
||||
(Listof Identifier)))
|
||||
(define (format-ids lex-ctx format . vs)
|
||||
(let* ([seqs
|
||||
(map (λ ([v : S-Id-List])
|
||||
(cond
|
||||
[(string? v) (in-cycle (in-value v))]
|
||||
[(identifier? v) (in-cycle (in-value v))]
|
||||
[(list? v) (in-list v)]
|
||||
[else (in-list (syntax->list v))]))
|
||||
vs)]
|
||||
[justconstants (andmap (λ (x) (or (string? x) (identifier? x))) vs)]
|
||||
[seqlst (apply sequence-list seqs)])
|
||||
(for/list : (Listof Identifier)
|
||||
([items seqlst]
|
||||
[bound-length (if justconstants
|
||||
(in-value 'yes)
|
||||
(in-cycle (in-value 'no)))])
|
||||
|
||||
(apply format-id
|
||||
(if (procedure? lex-ctx) (apply lex-ctx items) lex-ctx)
|
||||
format
|
||||
items))))
|
||||
|
||||
(: hyphen-ids (→ (U Syntax (→ (U String Identifier) * Syntax))
|
||||
S-Id-List *
|
||||
(Listof Identifier)))
|
||||
|
||||
(define (hyphen-ids lex-ctx . vs)
|
||||
(apply format-ids
|
||||
lex-ctx
|
||||
(string-join (map (λ _ "~a") vs) "-")
|
||||
vs))
|
||||
|
||||
(: format-temp-ids (→ String
|
||||
S-Id-List *
|
||||
(Listof Identifier)))
|
||||
|
||||
(define (format-temp-ids format . vs)
|
||||
;; Introduce the binding in a fresh scope.
|
||||
(apply format-ids (λ _ ((make-syntax-introducer) #'())) format vs))
|
||||
|
||||
;; Also in ==== syntax.rkt ====, once we split into multiple files, require it
|
||||
(begin-for-syntax
|
||||
(define (syntax-cons-property stx key v)
|
||||
(let ([orig (syntax-property stx key)])
|
||||
(syntax-property stx key (cons v (or orig '()))))))
|
||||
|
||||
;; Also in ==== syntax.rkt ====, once we split into multiple files, require it
|
||||
(begin-for-syntax
|
||||
(define (identifier-length id) (string-length (symbol->string
|
||||
(syntax-e id)))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class dotted
|
||||
(pattern id:id
|
||||
#:attr make-dotted
|
||||
(λ (x) x)
|
||||
#:attr wrap
|
||||
(λ (x f) (f x #t)))
|
||||
(pattern (nested:dotted (~literal ...));(~and dots (~literal ...)) ...+)
|
||||
#:with id #'nested.id
|
||||
#:attr make-dotted
|
||||
(λ (x) #`(#,((attribute nested.make-dotted) x) (... ...)));dots …
|
||||
#:attr wrap
|
||||
(λ (x f) (f ((attribute nested.wrap) x f) #f))))
|
||||
|
||||
(define-syntax-class simple-format
|
||||
(pattern format
|
||||
#:when (string? (syntax-e #'format))
|
||||
#:when (regexp-match #rx"^[^~]*~a[^~]*$" (syntax-e #'format))
|
||||
#:attr pos (regexp-match-positions #rx"^([^~]*)~a([^~]*)$"
|
||||
(syntax-e #'format))
|
||||
#:attr left-start 1
|
||||
#:attr left-end (+ 1 (cdr (cadr (attribute pos))))
|
||||
#:attr left-len (cdr (cadr (attribute pos)))
|
||||
|
||||
#:attr right-start (+ 1 (car (caddr (attribute pos))))
|
||||
#:attr right-end (+ 1 (cdr (caddr (attribute pos))))
|
||||
#:attr right-len (- (attribute right-end)
|
||||
(attribute right-start)))))
|
||||
|
||||
(define-syntax (define-temp-ids stx)
|
||||
(syntax-parse stx
|
||||
#|
|
||||
;; TODO : factor this with the next case.
|
||||
[(_ format ((base:id (~literal ...)) (~literal ...)))
|
||||
#:when (string? (syntax-e #'format))
|
||||
(with-syntax ([pat (format-id #'base (syntax-e #'format) #'base)])
|
||||
#'(define/with-syntax ((pat (... ...)) (... ...))
|
||||
(stx-map (curry format-temp-ids format)
|
||||
#'((base (... ...)) (... ...)))))]
|
||||
|#
|
||||
|
||||
;; New features (arrows and #:first) special-cased for now
|
||||
;; TODO: make these features more general.
|
||||
[(_ format:simple-format base:dotted #:first-base first-base)
|
||||
#:with first (format-id #'first-base (syntax-e #'format) #'first-base)
|
||||
(let ([first-base-len (identifier-length #'first-base)])
|
||||
(syntax-cons-property #'(define-temp-ids format base #:first first)
|
||||
'sub-range-binders
|
||||
(list
|
||||
(if (> (attribute format.left-len) 0)
|
||||
(vector (syntax-local-introduce #'first)
|
||||
0
|
||||
(attribute format.left-len)
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
(attribute format.left-start)
|
||||
(attribute format.left-len))
|
||||
'())
|
||||
(vector (syntax-local-introduce #'first)
|
||||
(attribute format.left-len)
|
||||
first-base-len
|
||||
|
||||
(syntax-local-introduce #'first-base)
|
||||
0
|
||||
first-base-len)
|
||||
(if (> (attribute format.right-len) 0)
|
||||
(vector (syntax-local-introduce #'first)
|
||||
(+ (attribute format.left-len)
|
||||
first-base-len)
|
||||
(attribute format.right-len)
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
(attribute format.right-start)
|
||||
(attribute format.right-len))
|
||||
'()))))]
|
||||
|
||||
[(_ format:simple-format
|
||||
base:dotted
|
||||
(~optional (~seq #:first first)))
|
||||
(let* ([base-len (string-length (symbol->string (syntax-e #'base.id)))])
|
||||
(define/with-syntax pat
|
||||
(format-id #'base.id (syntax-e #'format) #'base.id))
|
||||
(define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
|
||||
|
||||
(define/with-syntax format-temp-ids*
|
||||
((attribute base.wrap) #'(compose car
|
||||
(curry format-temp-ids format)
|
||||
generate-temporary)
|
||||
(λ (x deepest?)
|
||||
(if deepest?
|
||||
x
|
||||
#`(curry stx-map #,x)))))
|
||||
|
||||
(syntax-cons-property
|
||||
(template (begin (define/with-syntax pat-dotted
|
||||
(format-temp-ids* #'base))
|
||||
(?? (?@ (define/with-syntax (first . _)
|
||||
#'pat-dotted)))))
|
||||
'sub-range-binders
|
||||
(list (if (> (attribute format.left-len) 0)
|
||||
(vector (syntax-local-introduce #'pat)
|
||||
0
|
||||
(attribute format.left-len)
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
(attribute format.left-start)
|
||||
(attribute format.left-len))
|
||||
'())
|
||||
(vector (syntax-local-introduce #'pat)
|
||||
(attribute format.left-len)
|
||||
base-len
|
||||
|
||||
(syntax-local-get-shadower #'base.id)
|
||||
0
|
||||
base-len)
|
||||
(if (> (attribute format.right-len) 0)
|
||||
(vector (syntax-local-introduce #'pat)
|
||||
(+ (attribute format.left-len) base-len)
|
||||
(attribute format.right-len)
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
(attribute format.right-start)
|
||||
(attribute format.right-len))
|
||||
'()))))]
|
||||
[(_ format base:dotted)
|
||||
#:when (string? (syntax-e #'format))
|
||||
#:when (regexp-match #rx"^[^~]*$" (syntax-e #'format))
|
||||
(define/with-syntax pat (format-id #'base (syntax-e #'format)))
|
||||
(define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
|
||||
(define/with-syntax format-temp-ids*
|
||||
((attribute base.wrap) #'(λ (x)
|
||||
(car (format-temp-ids
|
||||
(string-append format "~a")
|
||||
"")))
|
||||
(λ (x deepest?)
|
||||
(if deepest?
|
||||
x
|
||||
#`(curry stx-map #,x)))))
|
||||
(syntax-cons-property
|
||||
#'(define/with-syntax pat-dotted
|
||||
(format-temp-ids* #'base))
|
||||
'sub-range-binders
|
||||
(list (vector (syntax-local-introduce #'pat)
|
||||
0
|
||||
(string-length (syntax-e #'format))
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
1
|
||||
(string-length (syntax-e #'format)))))]
|
||||
[(_ name:id format:expr . vs)
|
||||
#`(define/with-syntax name (format-temp-ids format . vs))]))
|
||||
|
||||
(module+ test
|
||||
(require-typed/untyped "typed-rackunit.rkt")
|
||||
(require ;(submod "..")
|
||||
(for-syntax racket/syntax
|
||||
(submod ".." ".." untyped)))
|
||||
|
||||
(check-equal?: (format-ids #'a "~a-~a" #'() #'())
|
||||
'())
|
||||
|
||||
(check-equal?: (map syntax->datum
|
||||
(format-ids #'a "~a-~a" #'(x1 x2 x3) #'(a b c)))
|
||||
'(x1-a x2-b x3-c))
|
||||
|
||||
;; Since the presence of "Syntax" in the parameters list makes format-ids
|
||||
;; require a chaperone contract instead of a flat contract, we can't run the
|
||||
;; two tests below directly, we would need to require the untyped version of
|
||||
;; this file, which causes a cycle in loading.
|
||||
|
||||
(define-syntax (test1 stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (let1 d1) x y)
|
||||
(begin
|
||||
(define/with-syntax (foo-x foo-y)
|
||||
(format-ids (λ (xy)
|
||||
(if (string=? (symbol->string (syntax->datum xy))
|
||||
"b")
|
||||
stx
|
||||
#'()))
|
||||
"foo-~a"
|
||||
#'(x y)))
|
||||
#'(let1 d1 (let ((foo-b 2) (foo-c 'b)) (cons foo-x foo-y))))]))
|
||||
|
||||
(check-equal?: (test1 (let ((foo-b 1) (foo-c 'a))) b c)
|
||||
'(1 . b))
|
||||
|
||||
(define-syntax (fubar stx)
|
||||
(define/with-syntax (v1 ...) #'(1 2 3))
|
||||
(define/with-syntax (v2 ...) #'('a 'b 'c))
|
||||
;; the resulting ab and ab should be distinct identifiers:
|
||||
(define/with-syntax (id1 ...) (format-temp-ids "~a" #'(ab cd ab)))
|
||||
(define/with-syntax (id2 ...) (format-temp-ids "~a" #'(ab cd ab)))
|
||||
#'(let ([id1 v1] ...)
|
||||
(let ([id2 v2] ...)
|
||||
(list (cons id1 id2) ...))))
|
||||
|
||||
(check-equal?: (fubar) '((1 . a) (2 . b) (3 . c)))))
|
||||
41
graph-lib/lib/low/list.rkt
Normal file
41
graph-lib/lib/low/list.rkt
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide indexof
|
||||
replace-first
|
||||
map+fold)
|
||||
|
||||
(: indexof (∀ (A B) (→ A (Listof B) (→ A B Any) (U #f Integer))))
|
||||
(define (indexof elt lst [compare equal?])
|
||||
(let rec ([lst lst] [index 0])
|
||||
(if (null? lst)
|
||||
#f
|
||||
(if (compare elt (car lst))
|
||||
index
|
||||
(rec (cdr lst) (+ index 1))))))
|
||||
|
||||
(: replace-first (∀ (A B C) (->* (B
|
||||
C
|
||||
(Listof (U A B)))
|
||||
(#:equal? (→ (U A B) (U A B) Any : #:+ B))
|
||||
(Rec R (U (Pairof (U A B) R)
|
||||
Null
|
||||
(Pairof C (Listof (U A B))))))))
|
||||
(define (replace-first from to l #:equal? [equal? eq?])
|
||||
(if (null? l)
|
||||
'()
|
||||
(if (equal? from (car l))
|
||||
(cons to (cdr l))
|
||||
(cons (car l)
|
||||
(replace-first from to (cdr l))))))
|
||||
|
||||
(: map+fold (∀ (E R A) (→ (→ E A (values R A)) A (Listof E)
|
||||
(Values (Listof R) A))))
|
||||
(define (map+fold f init-acc lst)
|
||||
(let ([result (foldl (λ ([item : E] [acc : (Pairof (Listof R) A)])
|
||||
(let-values ([(item new-acc) (f item (cdr acc))])
|
||||
(cons (cons item (car acc))
|
||||
new-acc)))
|
||||
(cons '() init-acc)
|
||||
lst)])
|
||||
(values (car result) (cdr result)))))
|
||||
|
|
@ -1,77 +1,80 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
racket/syntax
|
||||
racket/function
|
||||
racket/match
|
||||
syntax/stx))
|
||||
|
||||
(provide define-logn-ids)
|
||||
|
||||
(begin-for-syntax
|
||||
(define (insert make-node v ts)
|
||||
(match ts
|
||||
[`() `((,v))]
|
||||
[`(() . ,b) `((,v) . ,b)]
|
||||
[`((,a) . ,b) `(() . ,(insert make-node (make-node v a) b))]))
|
||||
(require "../low2/typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(require (for-syntax syntax/parse
|
||||
racket/syntax
|
||||
racket/function
|
||||
racket/match
|
||||
syntax/stx))
|
||||
|
||||
(define (merge-trees make-node ts)
|
||||
(match ts
|
||||
[`{[,a]} a]
|
||||
[`{[,a] [] . ,rest} (merge-trees make-node `{[,a] . ,rest})]
|
||||
[`{[] . ,rest} (merge-trees make-node rest)]
|
||||
[`{[,a] [,b] . ,rest} (merge-trees make-node
|
||||
`{[,(make-node a b)] . ,rest})]))
|
||||
(provide define-logn-ids)
|
||||
|
||||
(define (make-binary-tree l make-node make-leaf)
|
||||
(merge-trees make-node
|
||||
(foldl (curry insert make-node)
|
||||
'()
|
||||
(map make-leaf l)))))
|
||||
|
||||
(define-syntax (define-logn-ids stx)
|
||||
(syntax-parse stx
|
||||
[(_ matcher:id [id:id ty:id] ...)
|
||||
(define/with-syntax (tmp ...) (generate-temporaries #'(id ...)))
|
||||
(define bt
|
||||
(make-binary-tree (syntax->list #'([ty id . tmp] ...))
|
||||
(λ (x y) `(node ,(generate-temporary) ,x ,y))
|
||||
(λ (x) `(leaf ,(stx-car x)
|
||||
,(generate-temporary (stx-car x))
|
||||
,(stx-car (stx-cdr x))
|
||||
,(stx-cdr (stx-cdr x))))))
|
||||
(define (make-structs bt parent)
|
||||
(match bt
|
||||
[`(node ,s ,a ,b) #`(begin (struct #,s #,@parent ())
|
||||
#,(make-structs a (list s))
|
||||
#,(make-structs b (list s)))]
|
||||
[`(leaf ,t ,s ,a ,_) #`(begin (struct #,s #,@parent () #:type-name #,t)
|
||||
(define #,a (#,s)))]))
|
||||
(define (make-btd bt)
|
||||
(match bt
|
||||
[`(node ,s ,(and a `(,_ ,sa . ,_)) ,b)
|
||||
#`(if ((make-predicate #,sa) v-cache)
|
||||
#,(make-btd a)
|
||||
#,(make-btd b))]
|
||||
[`(leaf ,s ,a ,t ,tmp)
|
||||
tmp]))
|
||||
#`(begin #,(make-structs bt #'())
|
||||
(define-syntax (matcher stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:expr [(~literal id) tmp] ...)
|
||||
#'(let ([v-cache v])
|
||||
#,(make-btd bt))])))]))
|
||||
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
typed/rackunit)
|
||||
(begin-for-syntax
|
||||
(define (insert make-node v ts)
|
||||
(match ts
|
||||
[`() `((,v))]
|
||||
[`(() . ,b) `((,v) . ,b)]
|
||||
[`((,a) . ,b) `(() . ,(insert make-node (make-node v a) b))]))
|
||||
|
||||
(define (merge-trees make-node ts)
|
||||
(match ts
|
||||
[`{[,a]} a]
|
||||
[`{[,a] [] . ,rest} (merge-trees make-node `{[,a] . ,rest})]
|
||||
[`{[] . ,rest} (merge-trees make-node rest)]
|
||||
[`{[,a] [,b] . ,rest} (merge-trees make-node
|
||||
`{[,(make-node a b)] . ,rest})]))
|
||||
|
||||
(define (make-binary-tree l make-node make-leaf)
|
||||
(merge-trees make-node
|
||||
(foldl (curry insert make-node)
|
||||
'()
|
||||
(map make-leaf l)))))
|
||||
|
||||
(define-logn-ids match-x [a A] [b B] [c C] [d D] [e E])
|
||||
(define-syntax (define-logn-ids stx)
|
||||
(syntax-parse stx
|
||||
[(_ matcher:id [id:id ty:id] ...)
|
||||
(define/with-syntax (tmp ...) (generate-temporaries #'(id ...)))
|
||||
(define bt
|
||||
(make-binary-tree (syntax->list #'([ty id . tmp] ...))
|
||||
(λ (x y) `(node ,(generate-temporary) ,x ,y))
|
||||
(λ (x) `(leaf ,(stx-car x)
|
||||
,(generate-temporary (stx-car x))
|
||||
,(stx-car (stx-cdr x))
|
||||
,(stx-cdr (stx-cdr x))))))
|
||||
(define (make-structs bt parent)
|
||||
(match bt
|
||||
[`(node ,s ,a ,b) #`(begin (struct #,s #,@parent ())
|
||||
#,(make-structs a (list s))
|
||||
#,(make-structs b (list s)))]
|
||||
[`(leaf ,t ,s ,a ,_) #`(begin (struct #,s #,@parent
|
||||
()
|
||||
#:type-name #,t)
|
||||
(define #,a (#,s)))]))
|
||||
(define (make-btd bt)
|
||||
(match bt
|
||||
[`(node ,s ,(and a `(,_ ,sa . ,_)) ,b)
|
||||
#`(if ((make-predicate #,sa) v-cache)
|
||||
#,(make-btd a)
|
||||
#,(make-btd b))]
|
||||
[`(leaf ,s ,a ,t ,tmp)
|
||||
tmp]))
|
||||
#`(begin #,(make-structs bt #'())
|
||||
(define-syntax (matcher stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:expr [(~literal id) tmp] ...)
|
||||
#'(let ([v-cache v])
|
||||
#,(make-btd bt))])))]))
|
||||
|
||||
(check-equal? (match-x (ann b (U A B C D E))
|
||||
[a 1]
|
||||
[b 2]
|
||||
[c 3]
|
||||
[d 4]
|
||||
[e 5])
|
||||
2))
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
typed/rackunit)
|
||||
|
||||
(define-logn-ids match-x [a A] [b B] [c C] [d D] [e E])
|
||||
|
||||
(check-equal? (match-x (ann b (U A B C D E))
|
||||
[a 1]
|
||||
[b 2]
|
||||
[c 3]
|
||||
[d 4]
|
||||
[e 5])
|
||||
2)))
|
||||
53
graph-lib/lib/low/misc.rkt
Normal file
53
graph-lib/lib/low/misc.rkt
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide hash-set**
|
||||
;string-set!
|
||||
;string-copy!
|
||||
;string-fill!
|
||||
with-output-file)
|
||||
|
||||
(require (for-syntax syntax/parse syntax/parse/experimental/template))
|
||||
|
||||
;; hash-set**: hash-set a list of K V pairs.
|
||||
(begin
|
||||
(: hash-set** (∀ (K V)
|
||||
(→ (HashTable K V) (Listof (Pairof K V)) (HashTable K V))))
|
||||
(define (hash-set** h l)
|
||||
(if (null? l)
|
||||
h
|
||||
(hash-set** (hash-set h (caar l) (cdar l)) (cdr l)))))
|
||||
|
||||
;; Disable string mutation
|
||||
(begin
|
||||
(define-syntax (string-set! stx)
|
||||
(raise-syntax-error 'string-set! "Do not mutate strings." stx))
|
||||
(define-syntax (string-copy! stx)
|
||||
(raise-syntax-error 'string-copy! "Do not mutate strings." stx))
|
||||
(define-syntax (string-fill! stx)
|
||||
(raise-syntax-error 'string-fill! "Do not mutate strings." stx)))
|
||||
|
||||
;; with-output-file
|
||||
(begin
|
||||
#|
|
||||
(define-syntax (with-output-file stx)
|
||||
(syntax-parse stx
|
||||
[(_ filename:expr (~optional (~seq #:mode mode:expr))
|
||||
(~optional (~seq #:exists exists:expr))
|
||||
body ...)
|
||||
(template (with-output-to-file filename
|
||||
(λ () body ...)
|
||||
(?? (?@ #:mode mode))
|
||||
(?? (?@ #:exists exists))))]))
|
||||
|#
|
||||
|
||||
(define-syntax (with-output-file stx)
|
||||
(syntax-parse stx
|
||||
[(_ [var:id filename:expr]
|
||||
(~optional (~seq #:mode mode:expr))
|
||||
(~optional (~seq #:exists exists:expr))
|
||||
body ...)
|
||||
(template (call-with-output-file filename
|
||||
(λ (var) body ...)
|
||||
(?? (?@ #:mode mode))
|
||||
(?? (?@ #:exists exists))))]))))
|
||||
9
graph-lib/lib/low/modulepp.rkt
Normal file
9
graph-lib/lib/low/modulepp.rkt
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
#lang racket
|
||||
|
||||
(begin-for-syntax
|
||||
(define partially-defined-module++ (make-hash
|
||||
|
||||
(define-syntax (module++ stx)
|
||||
(syntax-case stx
|
||||
[(_ name lang . body)
|
||||
(syntax-local-lift-module-end-declaration #'define-module )
|
||||
|
|
@ -1,35 +1,35 @@
|
|||
#lang racket
|
||||
|
||||
(require syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
syntax/stx)
|
||||
|
||||
(provide multiassoc-syntax
|
||||
cdr-assoc-syntax
|
||||
tmpl-cdr-assoc-syntax)
|
||||
|
||||
(require "../low.rkt") ;; For the identifier "…"
|
||||
|
||||
;; TODO: cdr-stx-assoc is already defined in lib/low.rkt
|
||||
|
||||
(define (multiassoc-syntax query alist)
|
||||
(map stx-cdr
|
||||
(filter (λ (xy) (free-identifier=? query (stx-car xy)))
|
||||
(syntax->list alist))))
|
||||
|
||||
(define (cdr-assoc-syntax query alist)
|
||||
(stx-cdr (assoc-syntax query alist)))
|
||||
|
||||
(define (assoc-syntax query alist)
|
||||
(findf (λ (xy) (free-identifier=? query (stx-car xy)))
|
||||
(syntax->list alist)))
|
||||
|
||||
(define-template-metafunction (tmpl-cdr-assoc-syntax stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~optional (~seq #:default default)) query [k . v] …)
|
||||
(if (attribute default)
|
||||
(let ([r (assoc-syntax #'query #'([k . v] …))])
|
||||
(if r
|
||||
(stx-cdr r)
|
||||
#'default))
|
||||
(cdr-assoc-syntax #'query #'([k . v] …)))]))
|
||||
#lang typed/racket
|
||||
(require "../low2/typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide multiassoc-syntax
|
||||
cdr-assoc-syntax
|
||||
assoc-syntax)
|
||||
|
||||
(require "../low2/typed-untyped.rkt")
|
||||
(require-typed/untyped "../low2/aliases.rkt"
|
||||
"../low2/stx.rkt")
|
||||
|
||||
;; TODO: cdr-stx-assoc is already defined in lib/low.rkt
|
||||
|
||||
(define-type (Stx-AList A)
|
||||
(Syntaxof (Listof (Syntaxof (Pairof Identifier A)))))
|
||||
|
||||
(: multiassoc-syntax (∀ (A) (→ Identifier (Stx-AList A) (Listof A))))
|
||||
(define (multiassoc-syntax query alist)
|
||||
((inst map A (Syntaxof (Pairof Identifier A)))
|
||||
stx-cdr
|
||||
(filter (λ ([xy : (Syntaxof (Pairof Identifier A))])
|
||||
(free-identifier=? query (stx-car xy)))
|
||||
(syntax->list alist))))
|
||||
|
||||
(: cdr-assoc-syntax (∀ (A) (→ Identifier (Stx-AList A) A)))
|
||||
(define (cdr-assoc-syntax query alist)
|
||||
(stx-cdr (assert (assoc-syntax query alist))))
|
||||
|
||||
(: assoc-syntax (∀ (A) (→ Identifier
|
||||
(Stx-AList A)
|
||||
(U False (Syntaxof (Pairof Identifier A))))))
|
||||
(define (assoc-syntax query alist)
|
||||
(findf (λ ([xy : (Syntaxof (Pairof Identifier A))])
|
||||
(free-identifier=? query (stx-car xy)))
|
||||
(syntax->list alist))))
|
||||
|
|
|
|||
19
graph-lib/lib/low/not-implemented-yet.rkt
Normal file
19
graph-lib/lib/low/not-implemented-yet.rkt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide ? ?*)
|
||||
|
||||
(define-syntax (?* stx)
|
||||
(syntax-case stx ()
|
||||
[(q . rest)
|
||||
(quasisyntax/loc stx
|
||||
((λ () : (U) #,(syntax/loc #'q (error "Not implemented yet"))
|
||||
. rest)))]))
|
||||
|
||||
(define-syntax (? stx)
|
||||
(syntax-case stx ()
|
||||
[(q t . rest)
|
||||
(quasisyntax/loc stx
|
||||
((ann (λ () #,(syntax/loc #'q (error "Not implemented yet"))
|
||||
. rest)
|
||||
(→ t))))])))
|
||||
67
graph-lib/lib/low/percent.rkt
Normal file
67
graph-lib/lib/low/percent.rkt
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide % define%)
|
||||
|
||||
(require (for-syntax syntax/parse))
|
||||
|
||||
#|(define-syntax (% stx)
|
||||
(syntax-parse stx #:literals (= → :)
|
||||
[(_ (~seq (~or ((~and var (~not :)) ...)
|
||||
(~seq (~and var (~not (~or = → :))) ...)) = expr)
|
||||
...
|
||||
(~optional (~literal →)) . body)
|
||||
#'(let-values ([(var ...) expr] ...) . body)]))|#
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class %pat
|
||||
(pattern v:id
|
||||
#:with expanded #'v)
|
||||
(pattern ()
|
||||
#:with expanded #'(list))
|
||||
(pattern (x:%pat . rest:%pat)
|
||||
#:with expanded #'(cons x.expanded rest.expanded)))
|
||||
(define-splicing-syntax-class %assignment
|
||||
#:attributes ([pat.expanded 1] [expr 0])
|
||||
#:literals (= →)
|
||||
(pattern (~seq (~and maybe-pat (~not (~or = →))) ... (~datum =) expr:expr)
|
||||
#:with [pat:%pat ...] #'(maybe-pat ...))))
|
||||
|
||||
(define-syntax (% stx)
|
||||
(syntax-parse stx #:literals (= →)
|
||||
[(_ :%assignment ... (~optional (~literal →)) . body)
|
||||
#'(match-let*-values ([(pat.expanded ...) expr] ...) . body)]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class typed-pat
|
||||
(pattern [x:%pat (~literal :) type:expr]
|
||||
#:with (tmp) (generate-temporaries #'(x))
|
||||
#:with var-type #`[tmp : type]
|
||||
#:with (expanded ...) #'([x.expanded tmp]))
|
||||
(pattern x:id
|
||||
#:with var-type #'x
|
||||
#:with (expanded ...) #'())
|
||||
(pattern x:%pat
|
||||
#:with (tmp) (generate-temporaries #'(x))
|
||||
#:with var-type #'tmp
|
||||
#:with (expanded ...) #'([x.expanded tmp]))))
|
||||
|
||||
(define-syntax (define% stx)
|
||||
(syntax-parse stx
|
||||
[(_ (name param:typed-pat ...)
|
||||
(~and (~seq ret ...) (~optional (~seq (~literal :) ret-type)))
|
||||
. body)
|
||||
#'(define (name param.var-type ...)
|
||||
(match-let (param.expanded ... ...) ret ... . body))]))
|
||||
|
||||
#|
|
||||
(begin-for-syntax
|
||||
(define-syntax-class λ%expr
|
||||
(pattern e:id #:where (symbol->string e))
|
||||
(pattern e)
|
||||
(pattern (e . rest:λ%expr))))
|
||||
|
||||
(define-syntax (λ% stx)
|
||||
(syntax-parse stx
|
||||
[(_ expr )]))
|
||||
|#)
|
||||
114
graph-lib/lib/low/repeat-stx.rkt
Normal file
114
graph-lib/lib/low/repeat-stx.rkt
Normal file
|
|
@ -0,0 +1,114 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide repeat-stx)
|
||||
|
||||
(require syntax/stx
|
||||
(for-syntax racket/base
|
||||
racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
(define-for-syntax (repeat-stx-2 stx)
|
||||
(syntax-parse stx
|
||||
[(a:id b:id)
|
||||
#'(λ _ a)]
|
||||
[(a:id (b:expr (~literal ...)))
|
||||
#`(λ (bs) (stx-map #,(repeat-stx-2 #'(a b)) bs))]))
|
||||
|
||||
(define-for-syntax (repeat-stx-1 stx)
|
||||
(syntax-parse stx
|
||||
[(a:id b:expr)
|
||||
#`(λ (a bs) (#,(repeat-stx-2 #'(a b)) bs))]
|
||||
[((a:expr (~literal ...)) (b:expr (~literal ...)))
|
||||
#`(λ (s1 s2) (stx-map #,(repeat-stx-1 #'(a b)) s1 s2))]))
|
||||
|
||||
(define-syntax (repeat-stx stx)
|
||||
(syntax-parse stx
|
||||
[(_ a:expr b:expr)
|
||||
#`(#,(repeat-stx-1 #'(a b)) #'a #'b)])))
|
||||
|
||||
(module test racket
|
||||
(require (submod ".." untyped))
|
||||
(require syntax/parse
|
||||
rackunit)
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 2)
|
||||
[(a b)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a b)))])
|
||||
1)
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 2 3)
|
||||
[(a b ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a (b ...))))])
|
||||
'(1 1))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 (2 3) (uu vv ww) (xx yy))
|
||||
[(a (b ...) ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a ((b ...) ...))))])
|
||||
'((1 1) (1 1 1) (1 1)))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 ((2) (3 3)) ((uu) (vv vv) (ww ww ww)) ((xx) (yy)))
|
||||
[(a ((b ...) ...) ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a (((b ...) ...) ...))))])
|
||||
'(((1) (1 1)) ((1) (1 1) (1 1 1)) ((1) (1))))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'([1 x] [2 y] [3 z])
|
||||
[([a b] ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) (b ...))))])
|
||||
'(1 2 3))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'((1 2 3) (a b))
|
||||
[([a b ...] ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) ((b ...) ...))))])
|
||||
'((1 1) (a)))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(((1 2 3) (a b)) ((x y z t) (-1 -2)))
|
||||
[[[[a b ...] ...] ...]
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx ((a ...) ...) (((b ...) ...) ...))))])
|
||||
'(((1 1) (a)) ((x x x) (-1))))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'((f (1 2 3) (a b)) (g (x y z t) (-1 -2)))
|
||||
[[[a (b ...) ...] ...]
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) (((b ...) ...) ...))))])
|
||||
'(((f f f) (f f)) ((g g g g) (g g))))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'((h () ()) (i () (x y z) ()))
|
||||
[([a (b ...) ...] ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) (((b ...) ...) ...))))])
|
||||
'((() ()) (() (i i i) ()))))
|
||||
22
graph-lib/lib/low/require-provide.rkt
Normal file
22
graph-lib/lib/low/require-provide.rkt
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide require/provide)
|
||||
|
||||
(define-syntax (require/provide stx)
|
||||
(syntax-case stx ()
|
||||
[(_ require-spec ...)
|
||||
#'(begin
|
||||
(require require-spec ...)
|
||||
(provide (all-from-out require-spec ...)))]))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(module ma typed/racket
|
||||
(define require-provide-foo 7)
|
||||
(provide require-provide-foo))
|
||||
(module mb typed/racket
|
||||
(require (submod ".." ".."))
|
||||
(require/provide (submod ".." ma)))
|
||||
(require 'mb)
|
||||
(check-equal? require-provide-foo 7)))
|
||||
186
graph-lib/lib/low/sequence.rkt
Normal file
186
graph-lib/lib/low/sequence.rkt
Normal file
|
|
@ -0,0 +1,186 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide sequence-length>=
|
||||
in-last?
|
||||
in-tails
|
||||
in-heads
|
||||
in-split
|
||||
in-split*
|
||||
*in-split
|
||||
Syntax-Listof
|
||||
my-in-syntax
|
||||
in-syntax
|
||||
sequence-cons
|
||||
sequence-null
|
||||
sequence-list)
|
||||
|
||||
(require racket/sequence)
|
||||
|
||||
;; sequence-length>=
|
||||
(begin
|
||||
(: sequence-length>= (→ (Sequenceof Any) Index Boolean))
|
||||
(define (sequence-length>= s l)
|
||||
(let-values ([(more? next) (sequence-generate s)])
|
||||
(define (rec [remaining : Index]) : Boolean
|
||||
(if (= remaining 0)
|
||||
#t
|
||||
(and (more?)
|
||||
(begin (next)
|
||||
(rec (sub1 remaining))))))
|
||||
(rec l))))
|
||||
|
||||
;; in-last?
|
||||
;; Returns a sequence of the same length as `s`. All values in the sequence
|
||||
;; are #f, except for the last one which is 'last.
|
||||
(begin
|
||||
(: in-last? (→ (Sequenceof Any) (Sequenceof (U #f 'last))))
|
||||
(define (in-last? s)
|
||||
(if (sequence-length>= s 1)
|
||||
(sequence-append (sequence-map (λ _ #f) (sequence-tail s 1))
|
||||
(in-value 'last))
|
||||
empty-sequence)))
|
||||
|
||||
;; in-heads and in-tails
|
||||
(begin
|
||||
(: in-tails (∀ (T) (→ (Listof T) (Listof (Pairof T (Listof T))))))
|
||||
(define (in-tails l)
|
||||
(if (null? l)
|
||||
'()
|
||||
(cons l (in-tails (cdr l)))))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (for/list : (Listof (Listof Number))
|
||||
([x : (Listof Number) (in-tails '(1 2 3 4 5))]) x)
|
||||
'((1 2 3 4 5) (2 3 4 5) (3 4 5) (4 5) (5)))
|
||||
(let ((l '(1 2 3 4 5)))
|
||||
(check-true (eq? (caddr (for/list : (Listof (Listof Number))
|
||||
([x : (Listof Number) (in-tails l)]) x))
|
||||
(cddr l)))))
|
||||
|
||||
(: in-heads (∀ (T) (→ (Listof T) (Listof (Pairof T (Listof T))))))
|
||||
(define (in-heads l)
|
||||
(: my-append1 (→ (Listof T) T (Pairof T (Listof T))))
|
||||
(define (my-append1 x y)
|
||||
(if (null? x)
|
||||
(list y)
|
||||
(cons (car x) (my-append1 (cdr x) y))))
|
||||
|
||||
(define (on-heads/private [acc-head : (Listof T)] [l : (Listof T)])
|
||||
: (Listof (Pairof T (Listof T)))
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ([new-head (my-append1 acc-head (car l))])
|
||||
(cons new-head (on-heads/private new-head (cdr l))))))
|
||||
(on-heads/private '() l))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (for/list : (Listof (Listof Number))
|
||||
([x : (Listof Number) (in-heads '(1 2 3 4 5))]) x)
|
||||
'((1) (1 2) (1 2 3) (1 2 3 4) (1 2 3 4 5)))))
|
||||
|
||||
;; in-split, in-split*, *in-split, *in-split*
|
||||
(begin
|
||||
;; Can't write the type of in-split, because typed/racket doesn't allow
|
||||
;; writing (Sequenceof A B), just (Sequenceof A).
|
||||
;; in-parallel's type has access to the multi-valued version of Sequenceof,
|
||||
;; though, so we let typed/racket propagate the inferred type.
|
||||
(define #:∀ (T) (in-split [l : (Listof T)])
|
||||
(in-parallel (sequence-append (in-value '()) (in-heads l))
|
||||
(sequence-append (in-tails l) (in-value '()))))
|
||||
|
||||
;; Same as in-split, but without the empty tail.
|
||||
(define #:∀ (T) (in-split* [l : (Listof T)])
|
||||
(in-parallel (sequence-append (in-value '()) (in-heads l))
|
||||
(sequence-append (in-tails l))))
|
||||
|
||||
;; Same as in-split, but without the empty head.
|
||||
(define #:∀ (T) (*in-split [l : (Listof T)])
|
||||
(in-parallel (in-heads l)
|
||||
(sequence-append (sequence-tail (in-tails l) 1)
|
||||
(in-value '()))))
|
||||
|
||||
(define #:∀ (T) (*in-split* [l : (Listof T)])
|
||||
(in-parallel (in-heads l)
|
||||
(sequence-tail (in-tails l) 1))))
|
||||
|
||||
;; my-in-syntax and Syntax-Listof
|
||||
(begin
|
||||
;; See also syntax-e, which does not flatten syntax pairs, and syntax->list,
|
||||
;; which isn't correctly typed (won't take #'(a . (b c d e))).
|
||||
(define-type (Syntax-Listof T)
|
||||
(Rec R (Syntaxof (U Null
|
||||
(Pairof T R)
|
||||
(Listof T)))))
|
||||
|
||||
;; in-syntax is now provided by racket/sequence.
|
||||
(: my-in-syntax (∀ (T) (→ (Syntax-Listof T)
|
||||
(Listof T))))
|
||||
(define (my-in-syntax stx)
|
||||
(let ((e (syntax-e stx)))
|
||||
(if (null? e)
|
||||
e
|
||||
(if (syntax? (cdr e))
|
||||
(cons (car e) (my-in-syntax (cdr e)))
|
||||
e))))
|
||||
|
||||
(define (test-in-syntax)
|
||||
; (ann `(,#'(a . b) ,#'(c . d))
|
||||
; (Listof (Syntaxof (U (Pairof (Syntaxof 'a) (Syntaxof 'b))
|
||||
; (Pairof (Syntaxof 'c) (Syntaxof 'c))))))
|
||||
(my-in-syntax #'((a . b) (c . d)))
|
||||
; (ann `(,#'a ,#'b ,#'c ,#'d ,#'e) (Listof (Syntaxof (U 'a 'b 'c 'd))))
|
||||
(my-in-syntax #'(a . (b c d e)))
|
||||
; (ann '() (Listof (Syntaxof Nothing)))
|
||||
(my-in-syntax #'())))
|
||||
|
||||
;; combining sequences:
|
||||
;; sequence-cons
|
||||
;; sequence-null
|
||||
;; sequence-list
|
||||
|
||||
(begin
|
||||
(: sequence-cons (∀ (A B) (→ (Sequenceof A) (Sequenceof B)
|
||||
(Sequenceof (cons A B)))))
|
||||
(define (sequence-cons sa sb)
|
||||
(sequence-map (λ ([x : (List A B)]) (cons (car x) (cadr x)))
|
||||
(in-values-sequence (in-parallel sa sb))))
|
||||
|
||||
(: sequence-null (Sequenceof Null))
|
||||
(define sequence-null (in-cycle (in-value '())))
|
||||
|
||||
;; sequence-list should have the type:
|
||||
;; (∀ (A ...) (→ (Sequenceof A) ... (Sequenceof (List A ...)))))
|
||||
;; But the type system rejects the two definitions below.
|
||||
(: sequence-list (∀ (A) (→ (Sequenceof A) *
|
||||
(Sequenceof (Listof A)))))
|
||||
(define (sequence-list . sequences)
|
||||
(if (null? sequences)
|
||||
sequence-null
|
||||
(sequence-cons (car sequences)
|
||||
(apply sequence-list (cdr sequences)))))
|
||||
|
||||
#|
|
||||
(: sequence-list (∀ (A ...) (→ (Sequenceof A) ...
|
||||
(Sequenceof (List A ...)))))
|
||||
(define (sequence-list . sequences)
|
||||
(if (null? sequences)
|
||||
sequence-null
|
||||
(sequence-cons (car sequences)
|
||||
(apply sequence-list (cdr sequences)))))
|
||||
|#
|
||||
|
||||
#|
|
||||
(: sequence-list (∀ (F R ...)
|
||||
(case→ [→ (Sequenceof Null)]
|
||||
[→ (Sequenceof F) (Sequenceof R) ...
|
||||
(Sequenceof (List F R ...))])))
|
||||
(define sequence-list
|
||||
(case-lambda
|
||||
[()
|
||||
sequence-null]
|
||||
[(sequence . sequences)
|
||||
(sequence-cons sequence (apply sequence-list sequences))]))
|
||||
|#))
|
||||
6
graph-lib/lib/low/set.rkt
Normal file
6
graph-lib/lib/low/set.rkt
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide set-map→set)
|
||||
(: set-map→set (∀ (e b) (→ (Setof e) (→ e b) (Setof b))))
|
||||
(define (set-map→set s f) (list->set (set-map s f))))
|
||||
392
graph-lib/lib/low/stx.rkt
Normal file
392
graph-lib/lib/low/stx.rkt
Normal file
|
|
@ -0,0 +1,392 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide stx-list
|
||||
stx-e
|
||||
stx-pair
|
||||
|
||||
syntax-cons-property
|
||||
stx-map-nested
|
||||
identifier-length
|
||||
identifier->string
|
||||
(rename-out [identifier->string identifier→string])
|
||||
;stx-map-nested
|
||||
|
||||
stx-car
|
||||
stx-cdr
|
||||
stx-null?
|
||||
stx-pair?
|
||||
|
||||
stx-cons
|
||||
|
||||
Stx-List?
|
||||
Syntax-Pairs-of
|
||||
|
||||
stx-drop-last
|
||||
|
||||
stx-foldl
|
||||
|
||||
stx-assoc
|
||||
cdr-stx-assoc
|
||||
|
||||
check-duplicate-identifiers
|
||||
|
||||
nameof)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
(require-typed/untyped "sequence.rkt")
|
||||
|
||||
;; match-expanders:
|
||||
;; stx-list
|
||||
;; stx-e
|
||||
;; stx-pair
|
||||
(begin
|
||||
(define-match-expander stx-list
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat ...)
|
||||
#'(? syntax?
|
||||
(app syntax->list (list pat ...)))])))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (match #'(1 2 3)
|
||||
[(stx-list a b c) (list (syntax-e c)
|
||||
(syntax-e b)
|
||||
(syntax-e a))])
|
||||
'(3 2 1))
|
||||
|
||||
(check-equal? (match #'(1 2 3)
|
||||
[(stx-list a ...) (map (inst syntax-e Positive-Byte) a)])
|
||||
'(1 2 3))
|
||||
|
||||
#;(check-equal? (match #`(1 . (2 3))
|
||||
[(stx-list a b c) (list (syntax-e c)
|
||||
(syntax-e b)
|
||||
(syntax-e a))])
|
||||
'(3 2 1)))
|
||||
|
||||
;; stx-e
|
||||
(define-match-expander stx-e
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat)
|
||||
#'(? syntax?
|
||||
(app syntax-e pat))])))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (match #'x [(stx-e s) s]) 'x)
|
||||
(check-equal? (match #'(x . y) [(stx-e (cons a b)) (cons (syntax-e b)
|
||||
(syntax-e a))])
|
||||
'(y . x)))
|
||||
|
||||
(define-match-expander stx-pair
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat-car pat-cdr)
|
||||
#'(? syntax?
|
||||
(app syntax-e (cons pat-car pat-cdr)))])))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (match #'(x . y) [(stx-pair a b) (cons (syntax-e b)
|
||||
(syntax-e a))])
|
||||
'(y . x))
|
||||
(check-equal? (match #'(x y z) [(stx-pair a b) (cons (map syntax->datum b)
|
||||
(syntax->datum a))])
|
||||
'((y z) . x))))
|
||||
|
||||
;; utilities:
|
||||
;; syntax-cons-property
|
||||
;; identifier-length
|
||||
;; identifier->string
|
||||
;; stx-map-nested
|
||||
(begin
|
||||
(: syntax-cons-property (∀ (A) (→ (Syntaxof A) Symbol Any (Syntaxof A))))
|
||||
(define (syntax-cons-property stx key v)
|
||||
(let ([orig (syntax-property stx key)])
|
||||
(syntax-property stx key (cons v (or orig '())))))
|
||||
|
||||
(: identifier-length (→ Identifier Index))
|
||||
(define (identifier-length id) (string-length (identifier->string id)))
|
||||
|
||||
(: identifier->string (→ Identifier String))
|
||||
(define (identifier->string id) (symbol->string (syntax-e id)))
|
||||
|
||||
(: stx-map-nested (∀ (A B) (→ (→ A B)
|
||||
(Syntaxof (Listof (Syntaxof (Listof A))))
|
||||
(Listof (Listof B)))))
|
||||
(define (stx-map-nested f stx)
|
||||
(map (λ ([x : (Syntaxof (Listof A))])
|
||||
(map f (syntax-e x)))
|
||||
(syntax-e stx))))
|
||||
|
||||
;; accessors:
|
||||
;; stx-car
|
||||
;; stx-cdr
|
||||
;; stx-null?
|
||||
;; stx-pair?
|
||||
(begin
|
||||
#|
|
||||
(require/typed syntax/stx
|
||||
[stx-car (∀ (A B) (→ (Syntaxof (Pairof A B)) A))]
|
||||
[stx-cdr (∀ (A B) (→ (Syntaxof (Pairof A B)) B))])
|
||||
|#
|
||||
|
||||
(: stx-car (∀ (A B)
|
||||
(case→ (→ (Syntaxof (Pairof A B)) A)
|
||||
;; TODO: Not typesafe!
|
||||
(→ (U (Syntaxof (Listof A)) (Listof A)) A))))
|
||||
(define (stx-car p) (car (if (syntax? p) (syntax-e p) p)))
|
||||
|
||||
(: stx-cdr (∀ (A B)
|
||||
(case→ (→ (Syntaxof (Pairof A B))
|
||||
B)
|
||||
;; TODO: Not typesafe!
|
||||
(→ (U (Syntaxof (Listof A)) (Listof A))
|
||||
(Listof A)))))
|
||||
(define (stx-cdr p) (cdr (if (syntax? p) (syntax-e p) p)))
|
||||
|
||||
(: stx-null? (→ Any Boolean : (U (Syntaxof Null) Null)))
|
||||
(define (stx-null? v)
|
||||
((make-predicate (U (Syntaxof Null) Null)) v))
|
||||
|
||||
(: stx-pair? (→ Any Boolean : (U (Pairof Any Any)
|
||||
(Syntaxof (Pairof Any Any)))))
|
||||
(define (stx-pair? v)
|
||||
((make-predicate (U (Pairof Any Any)
|
||||
(Syntaxof (Pairof Any Any))))
|
||||
v)))
|
||||
|
||||
;; constructors:
|
||||
;; stx-cons
|
||||
(begin
|
||||
(module m-stx-cons-untyped racket
|
||||
(provide stx-cons list->stx list*->stx)
|
||||
|
||||
(define (stx-cons a b) #`(#,a . #,b))
|
||||
(define (list->stx l) #`#,l)
|
||||
(define (list*->stx l*) #`#,l*))
|
||||
|
||||
(if-typed
|
||||
(module m-stx-cons-typed typed/racket
|
||||
(provide stx-cons list->stx list*->stx)
|
||||
(require (only-in typed/racket/unsafe unsafe-require/typed))
|
||||
(unsafe-require/typed
|
||||
(submod ".." m-stx-cons-untyped)
|
||||
[stx-cons (∀ (A B)
|
||||
(→ (Syntaxof A)
|
||||
(Syntaxof B)
|
||||
(Syntaxof (Pairof (Syntaxof A) (Syntaxof B)))))]
|
||||
[list->stx (∀ (A)
|
||||
(→ (Listof (Syntaxof A))
|
||||
(Syntaxof (Listof (Syntaxof A)))))]
|
||||
[list*->stx (∀ (A B)
|
||||
(→ (Rec R (U B (Pairof (Syntaxof A) R)))
|
||||
(Syntaxof (Rec R (U B (Pairof (Syntaxof A) R))))))]))
|
||||
(module m-stx-cons-typed racket
|
||||
(provide stx-cons list->stx list*->stx)
|
||||
(require (submod ".." m-stx-cons-untyped))))
|
||||
|
||||
(require 'm-stx-cons-typed)
|
||||
|
||||
(module+ test
|
||||
(require ;(submod "..")
|
||||
typed/rackunit)
|
||||
|
||||
(check-equal? (syntax->datum
|
||||
(ann (stx-cons #'a #'(b c))
|
||||
(Syntaxof (Pairof (Syntaxof 'a)
|
||||
(Syntaxof (List (Syntaxof 'b)
|
||||
(Syntaxof 'c)))))))
|
||||
'(a b c))
|
||||
|
||||
(check-equal? (syntax->datum
|
||||
(ann (stx-cons #'1 (ann #'2 (Syntaxof 2)))
|
||||
(Syntaxof (Pairof (Syntaxof 1)
|
||||
(Syntaxof 2)))))
|
||||
'(1 . 2))))
|
||||
|
||||
;; stx-drop-last
|
||||
(begin
|
||||
(: drop-last (∀ (A) (→ (Listof A) (Listof A))))
|
||||
(define (drop-last l)
|
||||
(if (and (pair? l) (pair? (cdr l)))
|
||||
(cons (car l) (drop-last (cdr l)))
|
||||
'()))
|
||||
|
||||
(define-type (Stx-List? A)
|
||||
(U Null
|
||||
(Pairof A (Stx-List? A))
|
||||
(Syntaxof Null)
|
||||
(Syntaxof (Pairof A (Stx-List? A)))))
|
||||
|
||||
(define-type (Syntax-Pairs-of A)
|
||||
(U (Syntaxof Null)
|
||||
(Syntaxof (Pairof A (Syntax-Pairs-of A)))))
|
||||
|
||||
(module+ test
|
||||
(require-typed/untyped "typed-rackunit.rkt")
|
||||
|
||||
(check-ann #'() (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 2 3) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 2 . ()) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 . (2 . (3 . ()))) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 . (2 3 . ())) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 2 . (3 4 . (5))) (Stx-List? (Syntaxof Number))))
|
||||
|
||||
(: stx->list (∀ (A) (→ (Stx-List? (Syntaxof A)) (Listof (Syntaxof A)))))
|
||||
(define (stx->list l)
|
||||
(cond [(null? l)
|
||||
'()]
|
||||
[(pair? l)
|
||||
(cons (car l) (stx->list (cdr l)))]
|
||||
[else
|
||||
(stx->list (syntax-e l))]))
|
||||
|
||||
(: stx-drop-last
|
||||
(∀ (A) (→ (Stx-List? (Syntaxof A)) (Syntaxof (Listof (Syntaxof A))))))
|
||||
(define (stx-drop-last l)
|
||||
(list->stx (drop-last (stx->list l))))
|
||||
#|
|
||||
#;(cond [(null? l)
|
||||
#'()]
|
||||
[(pair? l)
|
||||
(cond [(null? (cdr l))
|
||||
#'()]
|
||||
[(pair? (cdr l))
|
||||
]
|
||||
[else
|
||||
(let* ([res (stx-drop-last (cdr l))]
|
||||
[e (syntax-e res)])
|
||||
(if (null? e)
|
||||
(stx-cons (car l) #'())
|
||||
(stx-cons (car l) res)))]
|
||||
[else
|
||||
(stx-drop-last (syntax-e l))])
|
||||
|
||||
#;(if ((make-predicate (Syntaxof Any)) l)
|
||||
(stx-drop-last (syntax-e l))
|
||||
(if (null? l)
|
||||
#'()
|
||||
(stx-cons (car l)
|
||||
(stx-drop-last (cdr l)))))))
|
||||
|#)
|
||||
|
||||
;; stx-foldl
|
||||
(begin
|
||||
(: stx-foldl
|
||||
(∀ (E F G Acc)
|
||||
(case→ (→ (→ E Acc Acc)
|
||||
Acc
|
||||
(U (Syntaxof (Listof E)) (Listof E))
|
||||
Acc)
|
||||
(→ (→ E F Acc Acc)
|
||||
Acc
|
||||
(U (Syntaxof (Listof E)) (Listof E))
|
||||
(U (Syntaxof (Listof F)) (Listof F))
|
||||
Acc)
|
||||
(→ (→ E F G Acc Acc)
|
||||
Acc
|
||||
(U (Syntaxof (Listof E)) (Listof E))
|
||||
(U (Syntaxof (Listof F)) (Listof F))
|
||||
(U (Syntaxof (Listof G)) (Listof G))
|
||||
Acc))))
|
||||
(define stx-foldl
|
||||
(case-lambda
|
||||
[(f acc l)
|
||||
(if (stx-null? l)
|
||||
acc
|
||||
(stx-foldl f (f (stx-car l) acc) (stx-cdr l)))]
|
||||
[(f acc l l2)
|
||||
(if (or (stx-null? l) (stx-null? l2))
|
||||
acc
|
||||
(stx-foldl f
|
||||
(f (stx-car l) (stx-car l2) acc)
|
||||
(stx-cdr l)
|
||||
(stx-cdr l2)))]
|
||||
[(f acc l l2 l3)
|
||||
(if (or (stx-null? l) (stx-null? l2) (stx-null? l3))
|
||||
acc
|
||||
(stx-foldl f
|
||||
(f (stx-car l) (stx-car l2) (stx-car l3) acc)
|
||||
(stx-cdr l)
|
||||
(stx-cdr l2)
|
||||
(stx-cdr l3)))])))
|
||||
|
||||
;; stx-assoc
|
||||
;; cdr-stx-assoc
|
||||
(begin
|
||||
(: stx-assoc (∀ (T) (case→
|
||||
(→ Identifier
|
||||
(U (Syntaxof (Listof (Syntaxof (Pairof Identifier
|
||||
T))))
|
||||
(Listof (Syntaxof (Pairof Identifier T))))
|
||||
(U (Syntaxof (Pairof Identifier T)) #f))
|
||||
(→ Identifier
|
||||
(Listof (Pairof Identifier T))
|
||||
(U (Pairof Identifier T) #f)))))
|
||||
(define (stx-assoc id alist)
|
||||
(let* ([e-alist (if (syntax? alist)
|
||||
(syntax->list alist)
|
||||
alist)]
|
||||
[e-e-alist (cond
|
||||
[(null? e-alist) '()]
|
||||
[(syntax? (car e-alist))
|
||||
(map (λ ([x : (Syntaxof (Pairof Identifier T))])
|
||||
(cons (stx-car x) x))
|
||||
e-alist)]
|
||||
[else
|
||||
(map (λ ([x : (Pairof Identifier T)])
|
||||
(cons (car x) x))
|
||||
e-alist)])]
|
||||
[result (assoc id e-e-alist free-identifier=?)])
|
||||
(if result (cdr result) #f)))
|
||||
|
||||
(: cdr-stx-assoc
|
||||
(∀ (T) (case→ (→ Identifier
|
||||
(U (Syntaxof (Listof (Syntaxof (Pairof Identifier T))))
|
||||
(Listof (Syntaxof (Pairof Identifier T)))
|
||||
(Listof (Pairof Identifier T)))
|
||||
(U T #f)))))
|
||||
(define (cdr-stx-assoc id alist)
|
||||
(if (null? alist)
|
||||
#f
|
||||
;; The typechecker is not precise enough, and the code below does not
|
||||
;; work if we factorize it:
|
||||
;; (if (and (list? alist) (syntax? (car alist))) … …)
|
||||
(if (list? alist)
|
||||
(if (syntax? (car alist))
|
||||
(let ((res (stx-assoc id alist)))
|
||||
(if res (stx-cdr res) #f))
|
||||
(let ((res (stx-assoc id alist)))
|
||||
(if res (cdr res) #f)))
|
||||
(let ((res (stx-assoc id alist)))
|
||||
(if res (stx-cdr res) #f))))))
|
||||
|
||||
;; check-duplicate-identifiers
|
||||
(begin
|
||||
(: check-duplicate-identifiers (→ (Syntaxof (Listof (Syntaxof Symbol)))
|
||||
Boolean))
|
||||
(define (check-duplicate-identifiers ids)
|
||||
(if (check-duplicate-identifier (my-in-syntax ids)) #t #f)))
|
||||
|
||||
;; nameof
|
||||
(begin
|
||||
;; TODO: use the proper way to introduce arrows if possible.
|
||||
(define-syntax-rule (nameof x) (begin x 'x))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(let ((y 3))
|
||||
(check-equal? (nameof y) 'y))))
|
||||
|
||||
#|
|
||||
(define (raise-multi-syntax-error name message exprs)
|
||||
(let ([e (exn:fail:syntax "message"
|
||||
(current-continuation-marks)
|
||||
(list #'aaa #'bbb))])
|
||||
((error-display-handler) (exn-message e) e)))
|
||||
|#)
|
||||
132
graph-lib/lib/low/syntax-parse.rkt
Normal file
132
graph-lib/lib/low/syntax-parse.rkt
Normal file
|
|
@ -0,0 +1,132 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide define-syntax/parse
|
||||
λ/syntax-parse
|
||||
~maybe
|
||||
~lit
|
||||
~or-bug
|
||||
define-simple-macro
|
||||
λstx
|
||||
template/debug
|
||||
quasitemplate/debug
|
||||
meta-eval)
|
||||
|
||||
(require syntax/parse
|
||||
syntax/parse/define
|
||||
syntax/parse/experimental/template
|
||||
(for-syntax racket/base
|
||||
racket/syntax))
|
||||
|
||||
(define-syntax ~maybe
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self pat ...)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
#`(#,(s #'~optional) (#,(s #'~seq) pat ...))]))))
|
||||
|
||||
;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in
|
||||
;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)])
|
||||
(define-syntax ~or-bug
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self pat ...)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
#`(#,(s #'~and) x (#,(s #'~parse) (#,(s #'~or) pat ...) #'x))]))))
|
||||
|
||||
(define-syntax ~lit
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self (~optional (~seq name:id (~literal ~))) lit)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
(if (attribute name)
|
||||
#`(#,(s #'~and) name (#,(s #'~literal) lit))
|
||||
#`(#,(s #'~literal) lit))]
|
||||
[(self (~optional (~seq name:id (~literal ~))) lit …)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
(if (attribute name)
|
||||
#`(#,(s #'~and) name (#,(s #'~seq) (#,(s #'~literal) lit)))
|
||||
#`(#,(s #'~seq) (#,(s #'~literal) lit)))]))))
|
||||
|
||||
(begin-for-syntax
|
||||
(require (for-syntax racket/base
|
||||
racket/stxparam)
|
||||
racket/stxparam)
|
||||
|
||||
(provide stx)
|
||||
|
||||
(define-syntax-parameter stx
|
||||
(lambda (stx)
|
||||
(raise-syntax-error (syntax-e stx)
|
||||
"Can only be used in define-syntax/parse"))))
|
||||
|
||||
(define-simple-macro (define-syntax/parse (name . args) body0 . body)
|
||||
(define-syntax (name stx2)
|
||||
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[(_ . args) body0 . body]))))
|
||||
|
||||
(define-simple-macro (λ/syntax-parse args . body)
|
||||
(λ (stx2)
|
||||
;(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[args . body])))
|
||||
|
||||
;; λstx
|
||||
(begin
|
||||
(define-syntax-rule (λstx (param ...) body ...)
|
||||
(λ (param ...)
|
||||
(with-syntax ([param param] ...)
|
||||
body ...)))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (syntax->datum ((λstx (foo bar) #'(foo bar)) #'a #'b))
|
||||
(syntax->datum #'(a b)))))
|
||||
|
||||
;; template/debug
|
||||
(begin
|
||||
(define-syntax (template/debug stx)
|
||||
(syntax-parse stx
|
||||
[(_ debug-attribute:id . rest)
|
||||
#'((λ (x)
|
||||
(when (attribute debug-attribute)
|
||||
(pretty-write (syntax->datum x)))
|
||||
x)
|
||||
(template . rest))])))
|
||||
|
||||
;; quasitemplate/debug
|
||||
(begin
|
||||
(define-syntax (quasitemplate/debug stx)
|
||||
(syntax-parse stx
|
||||
[(_ debug-attribute:id . rest)
|
||||
#'((λ (x)
|
||||
(when (attribute debug-attribute)
|
||||
(pretty-write (syntax->datum x)))
|
||||
x)
|
||||
(quasitemplate . rest))])))
|
||||
|
||||
;; meta-eval
|
||||
(begin
|
||||
;; TODO: this is kind of a hack, as we have to write:
|
||||
#;(with-syntax ([(x …) #'(a bb ccc)])
|
||||
(let ([y 70])
|
||||
(quasitemplate
|
||||
([x (meta-eval (+ #,y (string-length
|
||||
(symbol->string
|
||||
(syntax-e #'x)))))]
|
||||
…))))
|
||||
;; Where we need #,y instead of using:
|
||||
;; (+ y (string-length etc.)).
|
||||
(module m-meta-eval racket
|
||||
(provide meta-eval)
|
||||
(require syntax/parse/experimental/template)
|
||||
|
||||
(define-template-metafunction (meta-eval stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . body)
|
||||
#`#,(eval #'(begin . body))])))
|
||||
(require 'm-meta-eval)))
|
||||
21
graph-lib/lib/low/threading.rkt
Normal file
21
graph-lib/lib/low/threading.rkt
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
;; raco pkg install alexis-util
|
||||
;; or:
|
||||
;; raco pkg install threading
|
||||
(require alexis/util/threading
|
||||
(for-syntax racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
(define-syntax-rule (~>_ clause ... expr) (~> expr clause ...))
|
||||
(define-syntax (<~ stx)
|
||||
(syntax-parse stx
|
||||
[(_ expr clause ...)
|
||||
(define/with-syntax (r-clause ...)
|
||||
(reverse (syntax->list #'(clause ...))))
|
||||
#'(~> expr r-clause ...)]))
|
||||
|
||||
(define-syntax-rule (<~_ clause ... expr) (<~ expr clause ...))
|
||||
|
||||
(provide <~ <~_ ~>_ ~> ~>> _ (rename-out [_ ♦] [<~_ <~♦] [~>_ ~>♦])))
|
||||
26
graph-lib/lib/low/tmpl-multiassoc-syntax.rkt
Normal file
26
graph-lib/lib/low/tmpl-multiassoc-syntax.rkt
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
#lang typed/racket
|
||||
(require "../low2/typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide tmpl-cdr-assoc-syntax
|
||||
(rename-out [tmpl-cdr-assoc-syntax !cdr-assoc]))
|
||||
|
||||
(require "../low2/typed-untyped.rkt")
|
||||
|
||||
(module m-tmpl-cdr-assoc-syntax racket
|
||||
(provide tmpl-cdr-assoc-syntax)
|
||||
|
||||
(require syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
(submod "../low2/stx.rkt" untyped)
|
||||
(submod "multiassoc-syntax.rkt" untyped))
|
||||
|
||||
(define-template-metafunction (tmpl-cdr-assoc-syntax stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~optional (~seq #:default default)) query [k . v] …)
|
||||
(if (attribute default)
|
||||
(let ([r (assoc-syntax #'query #'([k . v] …))])
|
||||
(if r
|
||||
(stx-cdr r)
|
||||
#'default))
|
||||
(cdr-assoc-syntax #'query #'([k . v] …)))])))
|
||||
(require 'm-tmpl-cdr-assoc-syntax))
|
||||
25
graph-lib/lib/low/type-inference-helpers.rkt
Normal file
25
graph-lib/lib/low/type-inference-helpers.rkt
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide cars cdrs)
|
||||
|
||||
#|
|
||||
;; This does not work, in the end.
|
||||
(provide imap)
|
||||
(define-syntax (imap stx)
|
||||
(syntax-parse stx
|
||||
[(_ lst:expr var:id (~optional (~literal →)) . body)
|
||||
#'(let ()
|
||||
(define #:∀ (T) (inlined-map [l : (Listof T)])
|
||||
(if (null? l)
|
||||
'()
|
||||
(cons (let ([var (car l)]) . body)
|
||||
(inlined-map (cdr l)))))
|
||||
(inlined-map lst))]))
|
||||
|#
|
||||
|
||||
(: cars (∀ (A) (→ (Listof (Pairof A Any)) (Listof A))))
|
||||
(define (cars l) ((inst map A (Pairof A Any)) car l))
|
||||
|
||||
(: cdrs (∀ (B) (→ (Listof (Pairof Any B)) (Listof B))))
|
||||
(define (cdrs l) ((inst map B (Pairof Any B)) cdr l)))
|
||||
69
graph-lib/lib/low/typed-rackunit-extensions.rkt
Normal file
69
graph-lib/lib/low/typed-rackunit-extensions.rkt
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide check-equal?-classes
|
||||
check-equal?-classes:)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
(require-typed/untyped "syntax-parse.rkt"
|
||||
"sequence.rkt")
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
racket/syntax
|
||||
(submod "aliases.rkt" untyped)
|
||||
(submod "syntax-parse.rkt" untyped)
|
||||
(submod "repeat-stx.rkt" untyped))
|
||||
typed/rackunit)
|
||||
|
||||
(: check-equal?-classes (∀ (A ...) (→ (Pairof String (Listof A)) ... Void)))
|
||||
(define (check-equal?-classes . classes)
|
||||
(for* ([(head tail) (in-split* classes)])
|
||||
(let ([this-class (sequence-ref tail 0)]
|
||||
[different-classes (in-sequences head (sequence-tail tail 1))])
|
||||
(for ([val (cdr this-class)])
|
||||
(for ([other-val (cdr this-class)])
|
||||
#;(displayln (format "Test ~a ∈ ~a = ~a ∈ ~a …"
|
||||
val
|
||||
this-class
|
||||
other-val
|
||||
this-class))
|
||||
(check-equal? val other-val
|
||||
(format "Test ~a ∈ ~a = ~a ∈ ~a failed."
|
||||
val
|
||||
this-class
|
||||
other-val
|
||||
this-class)))
|
||||
(for ([different-class different-classes])
|
||||
(for ([different-val (cdr different-class)])
|
||||
#;(displayln (format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a …"
|
||||
val
|
||||
this-class
|
||||
different-val
|
||||
different-class
|
||||
(sequence->list different-classes)))
|
||||
(check-not-equal? val different-val
|
||||
(format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a failed."
|
||||
val
|
||||
this-class
|
||||
different-val
|
||||
different-class
|
||||
(sequence->list
|
||||
different-classes)))))))))
|
||||
|
||||
(define-syntax/parse (check-equal?-classes:
|
||||
(~seq [(~maybe #:name name:expr)
|
||||
(~maybe (~lit :) c-type)
|
||||
(~seq val (~maybe (~lit :) v-type)) …])
|
||||
…)
|
||||
(define/with-syntax ([a-val …] …)
|
||||
(template ([(?? (ann val v-type) val) …] …)))
|
||||
(define/with-syntax ([aa-val …] …)
|
||||
(let ()
|
||||
;; TODO: this is ugly, repeat-stx should handle missing stuff instead.
|
||||
(define/with-syntax (xx-c-type …) (template ((?? (c-type) ()) …)))
|
||||
(syntax-parse (repeat-stx (xx-c-type …) ([val …] …))
|
||||
[([((~optional c-type-rep)) …] …)
|
||||
(template ([(?? name "") (?? (ann a-val c-type-rep) a-val) …] …))])))
|
||||
(template
|
||||
(check-equal?-classes (list aa-val …) …))))
|
||||
95
graph-lib/lib/low/typed-rackunit.rkt
Normal file
95
graph-lib/lib/low/typed-rackunit.rkt
Normal file
|
|
@ -0,0 +1,95 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
;; TODO: these won't expand types in the ann.
|
||||
(provide check-equal?:
|
||||
check-not-equal?:
|
||||
check-ann)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
|
||||
(require/typed rackunit
|
||||
[(check-true untyped:check-true)
|
||||
(->* (Any) (String) Any)]
|
||||
[#:struct check-info ([name : Symbol] [value : Any])]
|
||||
[make-check-info (→ Symbol Any check-info)]
|
||||
[make-check-location (→ (List Any
|
||||
(U Number False)
|
||||
(U Number False)
|
||||
(U Number False)
|
||||
(U Number False))
|
||||
check-info)]
|
||||
[make-check-name (→ Any check-info)]
|
||||
[make-check-params (→ Any check-info)]
|
||||
[make-check-actual (→ Any check-info)]
|
||||
[make-check-expected (→ Any check-info)]
|
||||
[make-check-expression (→ Any check-info)]
|
||||
[make-check-message (→ Any check-info)]
|
||||
[with-check-info* (→ (Listof check-info) (→ Any) Any)])
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
syntax/parse/experimental/template))
|
||||
(require-typed/untyped "syntax-parse.rkt")
|
||||
|
||||
(define-syntax/parse
|
||||
(check-equal?: actual
|
||||
(~optional (~seq (~datum :) type))
|
||||
expected
|
||||
(~optional message:expr))
|
||||
(quasitemplate
|
||||
(with-check-info* (list (make-check-actual (format "~s" actual))
|
||||
(make-check-expected (format "~s" expected))
|
||||
(make-check-name 'check-equal?:)
|
||||
(make-check-params
|
||||
(format "~s" `(,actual (?? 'type) ,expected)))
|
||||
(make-check-location '(#,(syntax-source stx)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))
|
||||
(make-check-expression '#,(syntax->datum stx)))
|
||||
(λ ()
|
||||
(untyped:check-true
|
||||
(equal? (?? (ann actual type) actual)
|
||||
expected))))))
|
||||
|
||||
(define-syntax/parse
|
||||
(check-not-equal?: actual
|
||||
(~optional (~seq (~datum :) type))
|
||||
expected
|
||||
(~optional message))
|
||||
(quasitemplate
|
||||
(with-check-info* (list (make-check-actual (format "~s" actual))
|
||||
(make-check-expected (format "~s" expected))
|
||||
(make-check-name 'check-not-equal?:)
|
||||
(make-check-params
|
||||
(format "~s" `(,actual (?? 'type) ,expected)))
|
||||
(make-check-location '(#,(syntax-source stx)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))
|
||||
(make-check-expression '#,(syntax->datum stx)))
|
||||
(λ ()
|
||||
(untyped:check-true
|
||||
(not (equal? (?? (ann actual type) actual)
|
||||
expected)))))))
|
||||
|
||||
(define-syntax/parse (check-ann value type (~optional message))
|
||||
(quasitemplate
|
||||
((λ _ (void)) (ann value type))
|
||||
#;(let ([value-cache value])
|
||||
(with-check-info* (list (make-check-actual (format "~s" value-cache))
|
||||
(make-check-expected (format "~s" value-cache))
|
||||
(make-check-name 'check-ann)
|
||||
(make-check-params (format "~s" `(,value-cache
|
||||
type)))
|
||||
(make-check-location '(#,(syntax-source stx)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))
|
||||
(make-check-expression '#,(syntax->datum stx)))
|
||||
(λ ()
|
||||
(untyped:check-true
|
||||
(equal? (ann value type) value))))))))
|
||||
185
graph-lib/lib/low/typed-untyped.rkt
Normal file
185
graph-lib/lib/low/typed-untyped.rkt
Normal file
|
|
@ -0,0 +1,185 @@
|
|||
#lang racket
|
||||
|
||||
(provide ;typed/untyped
|
||||
require-typed/untyped-typed
|
||||
require-typed/untyped
|
||||
require/provide-typed/untyped
|
||||
define-typed/untyped-modules
|
||||
if-typed
|
||||
when-typed
|
||||
when-untyped)
|
||||
|
||||
(require typed/untyped-utils
|
||||
racket/require-syntax
|
||||
(for-syntax syntax/parse
|
||||
racket/syntax
|
||||
syntax/stx
|
||||
syntax/strip-context))
|
||||
|
||||
(module m-typed typed/racket
|
||||
(provide (rename-out [require tr:require]
|
||||
[provide tr:provide])
|
||||
;typed/untyped
|
||||
#;require-typed/untyped)
|
||||
|
||||
#;(require (for-syntax syntax/parse
|
||||
racket/syntax
|
||||
syntax/stx
|
||||
syntax/strip-context)
|
||||
racket/require-syntax)
|
||||
|
||||
|
||||
|
||||
#;(define-syntax (require-typed/untyped stx)
|
||||
(syntax-case stx ()
|
||||
[(_ m)
|
||||
(let ()
|
||||
(define/with-syntax sb (datum->syntax #'m 'submod #'m #'m))
|
||||
(define/with-syntax ty (datum->syntax #'m 'typed #'m #'m))
|
||||
#'(require (sb m ty)))])))
|
||||
|
||||
#;(require 'm-typed)
|
||||
|
||||
;; require
|
||||
(define-syntax (require-typed/untyped-typed stx)
|
||||
(syntax-parse stx
|
||||
[(_ . (~and ms (m ...)))
|
||||
(replace-context #'ms #'(require (submod m typed) ...))]))
|
||||
|
||||
#;(define-require-syntax (typed/untyped-typed stx)
|
||||
(syntax-case stx ()
|
||||
[(_ m) (replace-context stx #'(submod m typed))]))
|
||||
|
||||
#;(define-require-syntax (typed/untyped-untyped stx)
|
||||
(syntax-case stx ()
|
||||
[(_ m) (replace-context stx #'(submod m untyped))]))
|
||||
|
||||
(define-syntax (require-typed/untyped-untyped stx)
|
||||
(syntax-parse stx
|
||||
[(_ . (~and ms (m ...)))
|
||||
(replace-context #'ms #'(require (submod m untyped) ...))]))
|
||||
|
||||
(define-typed/untyped-identifier require-typed/untyped
|
||||
require-typed/untyped-typed
|
||||
require-typed/untyped-untyped)
|
||||
|
||||
#;(define-typed/untyped-identifier typed/untyped
|
||||
typed/untyped-typed
|
||||
typed/untyped-untyped)
|
||||
|
||||
;; require/provide
|
||||
;; TODO: make a require expander instead.
|
||||
(define-syntax (require/provide-typed/untyped-typed stx)
|
||||
(syntax-parse stx
|
||||
[(_ . (~and ms (m ...)))
|
||||
(replace-context #'ms
|
||||
#'(begin
|
||||
(require (submod m typed) ...)
|
||||
(provide (all-from-out (submod m typed) ...))))]))
|
||||
|
||||
(define-syntax (require/provide-typed/untyped-untyped stx)
|
||||
(syntax-parse stx
|
||||
[(_ . (~and ms (m ...)))
|
||||
(replace-context #'ms
|
||||
#'(begin
|
||||
(require (submod m untyped) ...)
|
||||
(provide (all-from-out (submod m untyped) ...))))]))
|
||||
|
||||
(define-typed/untyped-identifier require/provide-typed/untyped
|
||||
require/provide-typed/untyped-typed
|
||||
require/provide-typed/untyped-untyped)
|
||||
|
||||
#|
|
||||
(module mt typed/racket
|
||||
(define-syntax-rule (require/provide-typed/untyped m)
|
||||
(require m))
|
||||
(provide require/provide-typed/untyped))
|
||||
(require 'mt)
|
||||
|#
|
||||
|
||||
;; define-typed/untyped-modules
|
||||
(begin
|
||||
(define-syntax (define-typed/untyped-modules stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~optional (~and no-test #:no-test))
|
||||
(~optional (~and untyped-first #:untyped-first)) . body)
|
||||
(define (ds sym) (datum->syntax stx sym stx))
|
||||
(define/with-syntax module-typed
|
||||
#`(module #,(ds 'typed) #,(ds 'typed/racket)
|
||||
. body))
|
||||
(define/with-syntax module-untyped
|
||||
#`(module #,(ds 'untyped) #,(ds 'typed/racket/no-check)
|
||||
(#,(ds 'require) (#,(ds 'for-syntax) #,(ds 'racket/base)))
|
||||
. body))
|
||||
#`(begin
|
||||
#,(if (attribute untyped-first) #'module-untyped #'module-typed)
|
||||
#,(if (attribute untyped-first) #'module-typed #'module-untyped)
|
||||
#,@(if (attribute no-test)
|
||||
#'()
|
||||
#`((module #,(ds 'test) #,(ds 'typed/racket)
|
||||
(#,(ds 'require) (#,(ds 'submod) #,(ds "..")
|
||||
#,(ds 'typed)
|
||||
#,(ds 'test))
|
||||
(#,(ds 'submod) #,(ds "..")
|
||||
#,(ds 'untyped)
|
||||
#,(ds 'test))))))
|
||||
(#,(ds 'require) '#,(ds 'typed))
|
||||
(#,(ds 'provide) (#,(ds 'all-from-out) '#,(ds 'typed))))]))
|
||||
|
||||
#| ;; test: should work in no-check but not in typed:
|
||||
(define-typed/untyped-modules moo
|
||||
(: foo One)
|
||||
(define foo 2))
|
||||
|#)
|
||||
|
||||
;; if-typed
|
||||
(define-syntax-rule (if-typed-typed t u) t)
|
||||
(define-syntax-rule (if-typed-untyped t u) u)
|
||||
(define-typed/untyped-identifier if-typed
|
||||
if-typed-typed
|
||||
if-typed-untyped)
|
||||
|
||||
;; when-typed and when-untyped
|
||||
(define-syntax-rule (when-typed . t) (if-typed (begin . t) (begin)))
|
||||
(define-syntax-rule (when-untyped . t) (if-typed (begin) (begin . t)))
|
||||
|
||||
;; typed/untyped-prefix
|
||||
(begin
|
||||
(define-syntax-rule (typed/untyped-prefix [typed-prefix ...]
|
||||
[untyped-prefix ...]
|
||||
. rest)
|
||||
(if-typed (typed-prefix ... . rest)
|
||||
(untyped-prefix ... . rest)))
|
||||
#|
|
||||
;; test: should work in no-check but not in typed:
|
||||
(typed/untyped-prefix
|
||||
[module moo2 typed/racket]
|
||||
[module moo2 typed/racket/no-check]
|
||||
(: foo One)
|
||||
(define foo 2))
|
||||
|#)
|
||||
|
||||
;; define-modules
|
||||
(begin
|
||||
;; define-modules
|
||||
(define-syntax define-modules
|
||||
(syntax-rules (no-submodule)
|
||||
[(_ ([no-submodule] [name lang] ...) . body)
|
||||
(begin (begin . body)
|
||||
(module name lang . body) ...)]
|
||||
[(_ ([name lang] ...) . body)
|
||||
(begin (module name lang . body) ...)]))
|
||||
|
||||
#|
|
||||
;; TODO: tests: test with a macro and check that we can use it in untyped.
|
||||
;; TODO: tests: test with two mini-languages with different semantics for some
|
||||
;; function.
|
||||
(define-modules ([foo typed/racket] [foo-untyped typed/racket/no-check])
|
||||
(provide x)
|
||||
(: x (→ Syntax Syntax))
|
||||
(define (x s) s))
|
||||
|
||||
(module test racket
|
||||
(require (submod ".." foo-untyped))
|
||||
(x #'a))
|
||||
|#)
|
||||
37
graph-lib/lib/low/values.rkt
Normal file
37
graph-lib/lib/low/values.rkt
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide first-value second-value third-value fourth-value fifth-value
|
||||
sixth-value seventh-value eighth-value ninth-value tenth-value
|
||||
cons→values
|
||||
(rename-out [cons→values cons->values]))
|
||||
|
||||
(define-syntax-rule (define-value-getter name v ... last-v)
|
||||
(define-syntax-rule (name expr)
|
||||
(call-with-values (λ () expr) (λ (v ... last-v . rest) last-v))))
|
||||
|
||||
(define-value-getter first-value v1)
|
||||
(define-value-getter second-value v1 v2)
|
||||
(define-value-getter third-value v1 v2 v3)
|
||||
(define-value-getter fourth-value v1 v2 v3 v4)
|
||||
(define-value-getter fifth-value v1 v2 v3 v4 v5)
|
||||
(define-value-getter sixth-value v1 v2 v3 v4 v5 v6)
|
||||
(define-value-getter seventh-value v1 v2 v3 v4 v5 v6 v7)
|
||||
(define-value-getter eighth-value v1 v2 v3 v4 v5 v6 v7 v8)
|
||||
(define-value-getter ninth-value v1 v2 v3 v4 v5 v6 v7 v8 v9)
|
||||
(define-value-getter tenth-value v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (first-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 1)
|
||||
(check-equal? (second-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 2)
|
||||
(check-equal? (third-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 3)
|
||||
(check-equal? (fourth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 4)
|
||||
(check-equal? (fifth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 5)
|
||||
(check-equal? (sixth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 6)
|
||||
(check-equal? (seventh-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 7)
|
||||
(check-equal? (eighth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 8)
|
||||
(check-equal? (ninth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 9)
|
||||
(check-equal? (tenth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 10))
|
||||
|
||||
(define #:∀ (A B) (cons→values [x : (Pairof A B)]) (values (car x) (cdr x))))
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
#lang typed/racket
|
||||
|
||||
(provide sequence-cons sequence-null sequence-list)
|
||||
|
||||
(: sequence-cons (∀ (A B) (→ (Sequenceof A) (Sequenceof B)
|
||||
(Sequenceof (cons A B)))))
|
||||
(define (sequence-cons sa sb)
|
||||
(sequence-map (λ ([x : (List A B)]) (cons (car x) (cadr x)))
|
||||
(in-values-sequence (in-parallel sa sb))))
|
||||
|
||||
(: sequence-null (Sequenceof Null))
|
||||
(define sequence-null (in-cycle (in-value '())))
|
||||
|
||||
;; sequence-list should have the type:
|
||||
;; (∀ (A ...) (→ (Sequenceof A) ... (Sequenceof (List A ...)))))
|
||||
;; But the type system rejects the two definitions below.
|
||||
(: sequence-list (∀ (A) (→ (Sequenceof A) *
|
||||
(Sequenceof (Listof A)))))
|
||||
(define (sequence-list . sequences)
|
||||
(if (null? sequences)
|
||||
sequence-null
|
||||
(sequence-cons (car sequences) (apply sequence-list (cdr sequences)))))
|
||||
|
||||
#|
|
||||
(: sequence-list (∀ (A ...) (→ (Sequenceof A) ...
|
||||
(Sequenceof (List A ...)))))
|
||||
(define (sequence-list . sequences)
|
||||
(if (null? sequences)
|
||||
sequence-null
|
||||
(sequence-cons (car sequences) (apply sequence-list (cdr sequences)))))
|
||||
|#
|
||||
|
||||
#|
|
||||
(: sequence-list (∀ (F R ...)
|
||||
(case→ [→ (Sequenceof Null)]
|
||||
[→ (Sequenceof F) (Sequenceof R) ...
|
||||
(Sequenceof (List F R ...))])))
|
||||
(define sequence-list
|
||||
(case-lambda
|
||||
[()
|
||||
sequence-null]
|
||||
[(sequence . sequences)
|
||||
(sequence-cons sequence (apply sequence-list sequences))]))
|
||||
|#
|
||||
|
||||
Loading…
Reference in New Issue
Block a user