diff --git a/.travis.yml b/.travis.yml index 0c46b86c..d4a35398 100644 --- a/.travis.yml +++ b/.travis.yml @@ -47,6 +47,7 @@ install: - make build-dep script: +- racket --version - make after_success: diff --git a/graph-lib/README.md b/graph-lib/README.md index 23c4fd93..f70cea16 100644 --- a/graph-lib/README.md +++ b/graph-lib/README.md @@ -201,15 +201,11 @@ Library functions and utilities Utilities that complement racket and typed/racket's standard libraries. -* `lib/low.rkt` +* `lib/low.rkt` and `lib/low/*.rkt` Lower-level utilities that complement racket and typed/racket's standard libraries. -* `lib/low-untyped.rkt` - - Wrapper around `lib/low.rkt` that allows using it from a untyped racket file. - * `lib/untyped/for-star-list-star.rkt` A utility macro similar to `for*/list` to iterate over collections and return @@ -218,7 +214,8 @@ Library functions and utilities * `lib/untyped.rkt` - Aggregates `lib/low-untyped.rkt`, and `lib/untyped/for-star-list-star.rkt`. + Aggregates `(submod "lib/low.rkt" untyped)`, and + `lib/untyped/for-star-list-star.rkt`. * `lib/test-framework.rkt` diff --git a/graph-lib/graph/dotlang.rkt b/graph-lib/graph/dotlang.rkt index e53a2aa8..16e8f565 100644 --- a/graph-lib/graph/dotlang.rkt +++ b/graph-lib/graph/dotlang.rkt @@ -11,16 +11,15 @@ (require "get.lp2.rkt" - "../lib/low-untyped.rkt" + (submod "../lib/low.rkt" untyped) (for-syntax racket/string syntax/parse racket/syntax - syntax/stx syntax/strip-context racket/struct racket/function syntax/srcloc - "../lib/low-untyped.rkt")) + (submod "../lib/low.rkt" untyped))) #| (define-syntax/parse (dot x:id) diff --git a/graph-lib/graph/fold-queues.lp2.rkt b/graph-lib/graph/fold-queues.lp2.rkt index 4db68bf0..5cba39b3 100644 --- a/graph-lib/graph/fold-queues.lp2.rkt +++ b/graph-lib/graph/fold-queues.lp2.rkt @@ -226,7 +226,7 @@ position in the vector equal to the index associated to it in the hash table: (require (for-syntax syntax/parse syntax/parse/experimental/template racket/syntax - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) "../lib/low.rkt" "../type-expander/type-expander.lp2.rkt") diff --git a/graph-lib/graph/get.lp2.rkt b/graph-lib/graph/get.lp2.rkt index 44419159..93a3a0f2 100644 --- a/graph-lib/graph/get.lp2.rkt +++ b/graph-lib/graph/get.lp2.rkt @@ -201,7 +201,7 @@ The type for the function generated by @tc[λget] mirrors the cases from (module main typed/racket (require (for-syntax syntax/parse racket/syntax - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) "../lib/low.rkt" "structure.lp2.rkt" "variant.lp2.rkt" diff --git a/graph-lib/graph/graph-5-multi-ctors.lp2.rkt b/graph-lib/graph/graph-5-multi-ctors.lp2.rkt index f6d5c59b..07cc9f07 100644 --- a/graph-lib/graph/graph-5-multi-ctors.lp2.rkt +++ b/graph-lib/graph/graph-5-multi-ctors.lp2.rkt @@ -150,9 +150,7 @@ name) with the right type, so that the user doesn't see all the types in the (require (for-syntax syntax/parse syntax/parse/experimental/template racket/syntax - syntax/stx - "../lib/low-untyped.rkt" - "../lib/low/multiassoc-syntax.rkt") + (submod "../lib/low.rkt" untyped)) "../lib/low.rkt" "graph.lp2.rkt" "get.lp2.rkt" diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index c0102ab9..f5b72762 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -162,11 +162,8 @@ encapsulating the result types of mappings. (require (for-syntax syntax/parse syntax/parse/experimental/template racket/syntax - syntax/stx - "../lib/low-untyped.rkt" - "../lib/low/multiassoc-syntax.rkt" - "rewrite-type.lp2.rkt"; debug - ) + (submod "../lib/low.rkt" untyped) + "rewrite-type.lp2.rkt" #|debug|#) (rename-in "../lib/low.rkt" [~> threading:~>]) "graph.lp2.rkt" "get.lp2.rkt" diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index 0223ff7e..5a3fe738 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -761,12 +761,11 @@ We will be able to use this type expander in function types, for example: (module main typed/racket (require (for-syntax syntax/parse racket/syntax - syntax/stx syntax/parse/experimental/template racket/sequence racket/pretty "rewrite-type.lp2.rkt" - "../lib/low-untyped.rkt" + (submod "../lib/low.rkt" untyped) "meta-struct.rkt") racket/splicing "fold-queues.lp2.rkt" diff --git a/graph-lib/graph/graph2.lp2.rkt_ b/graph-lib/graph/graph2.lp2.rkt_ deleted file mode 100644 index 2b19a215..00000000 --- a/graph-lib/graph/graph2.lp2.rkt_ +++ /dev/null @@ -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[ - [City [streets : (Listof Street)] [people : (Listof Person)] ] - [Street [houses : (Listof House)] ] - [House [owner : Person] [location : Street] ] - [Person [name : String]] ] - -Notice the cycle in the type: a street contains houses, which are located on the -same street. - -@subsubsection{A seed from which to unravel the graph: the root parameters} - -In order to build a graph with that type, we start from the root parameters. -Here, we will take a representation of the city as a list of -@tc[(street . person-name)] pairs, and will convert it to a more convenient -graph representation. Our single root parameter will thus be the whole list: - -@chunk[ - '(["Amy" . "Ada street"] - ["Jack" . "J street"] - ["Anabella" . "Ada street"])] - -We 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 [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 [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 [s : String] - [c : (Listof (Pairof String String))] - [p : String]) - : House - (House (m-person p) (m-street c s))]] - -@chunk[ - [(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-graph-constructor () - )] - - @subsubsection{Creating a graph instance} - - @chunk[ - (define g )] -} - -@subsection{More details on the semantics} - -Let's take a second look at the root mapping: - -@chunk[ - [(m-city [c : (Listof (Pairof String String))]) : City - (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[ - (make-graph-constructor - (root-expr:expr ...) - ([node … ] …))] - -Where @tc[] is: - -@chunk[ - [field-name:id (~literal :) field-type:expr]] - -And @tc[] is: - -@chunk[ - ((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-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/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[ - 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[ - ] - -@; 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-queues - [(mapping/placeholder-tag [e : ] - Δ-queues - enqueue) - : - ] - ...)] - -@subsection{Making placeholders for mappings} - -We start creating the root placeholder which we provide to @tc[fold-queues]. - -@chunk[ - (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-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-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-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-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-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[ - (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/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[ - (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-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[ - [node/incomplete-type - node/with-promises-type - (λ (x) (and (pair? x) (eq? (car x) 'node/incomplete-tag))) - (λ ([x : node/incomplete-type] [acc : Void]) - )]] - -@chunk[ - [mapping/placeholder-type - (tmpl-replace-in-type result-type [node node/with-promises-type] …) - (λ (x) (and (pair? x) - (eq? (car x) 'mapping/placeholder-tag))) - (λ ([x : mapping/placeholder-type] [acc : Void]) - )]] - - -@; TODO: this would be much simpler if we forced having only one mapping per -@; node, and extended that with a macro. - -@chunk[ - (define/with-syntax ((node/compatible-mappings ...) ...) - (for/list ([x (in-syntax #'(node ...))]) - (multiassoc-syntax - x - #'([result-type . mapping] - …))))] - -@chunk[ - (error (~a "Not implemented yet " x))] - -@chunk[ - (% index new-Δ-queues = (enqueue 'mapping/placeholder-tag x Δ-queues) - (list 'mapping/placeholder-tag index) - (error (~a "Not implemented yet " x)))] - - -@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[ - (let ([mapping-result (apply mapping/function (cdr e))]) - (tmpl-fold-instance - Void - … - …)) - 'todo!] - -@chunk[ - (tmpl-cdr-assoc-syntax result-type - [node . (List …)] - …)] - -@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-type mapping/incomplete-result-type - (tmpl-replace-in-type result-type - [node (List 'node/incomplete-tag - …)] - …)) - - (: 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-temp-ids "~a/function" (mapping ...)) - (define-temp-ids "~a/incomplete-result-type" (mapping ...))] - -@section{Temporary fillers} - -@chunk[ - Any] - - -@section{Putting it all together} - -@chunk[ - (define-syntax/parse - - (let () - - - ((λ (x) (pretty-write (syntax->datum x)) x) - (template - (let () - (begin ) … - (begin ) … - (begin ) … - (begin ) … - )))))] - -@section{Conclusion} - -@chunk[ - (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 - ) - - (provide make-graph-constructor) - )] - -@chunk[ - (module* test typed/racket - (require (submod "..") - "fold-queues.lp2.rkt"; DEBUG - "rewrite-type.lp2.rkt"; DEBUG - "../lib/low.rkt"; DEBUG - typed/rackunit) - - - - g)] - -@chunk[<*> - (begin - - - (require 'main) - (provide (all-from-out 'main)) - - )] \ No newline at end of file diff --git a/graph-lib/graph/graph_old.lp2.rkt b/graph-lib/graph/graph_old.lp2.rkt index 42a3b6fb..a9dfa1ee 100644 --- a/graph-lib/graph/graph_old.lp2.rkt +++ b/graph-lib/graph/graph_old.lp2.rkt @@ -840,9 +840,8 @@ checker, unless it is absorbed by a larger type, like in syntax/parse/experimental/template racket/syntax racket/function - syntax/stx racket/pretty - "../lib/low-untyped.rkt" + (submod "../lib/low.rkt" untyped) "../lib/untyped.rkt") (prefix-in DEBUG-tr: typed/racket) syntax/parse diff --git a/graph-lib/graph/map.rkt b/graph-lib/graph/map.rkt index 0f361258..addb6547 100644 --- a/graph-lib/graph/map.rkt +++ b/graph-lib/graph/map.rkt @@ -2,9 +2,8 @@ (require (for-syntax racket/syntax racket/function - syntax/stx syntax/parse - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) "../lib/low.rkt" "get.lp2.rkt" "../type-expander/type-expander.lp2.rkt") diff --git a/graph-lib/graph/map1.rkt b/graph-lib/graph/map1.rkt index 7b241756..ab6f20e0 100644 --- a/graph-lib/graph/map1.rkt +++ b/graph-lib/graph/map1.rkt @@ -1,7 +1,7 @@ #lang typed/racket (require (for-syntax syntax/parse - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) "../type-expander/type-expander.lp2.rkt") (provide curry-map) diff --git a/graph-lib/graph/map3.rkt b/graph-lib/graph/map3.rkt index a3de16f4..68f8d5ce 100644 --- a/graph-lib/graph/map3.rkt +++ b/graph-lib/graph/map3.rkt @@ -1,10 +1,9 @@ #lang typed/racket (require (for-syntax racket/syntax - syntax/stx syntax/parse syntax/parse/experimental/template - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) "../lib/low.rkt" "get.lp2.rkt" "../type-expander/type-expander.lp2.rkt") diff --git a/graph-lib/graph/map_old.rkt b/graph-lib/graph/map_old.rkt index a244e1f2..9771bb54 100644 --- a/graph-lib/graph/map_old.rkt +++ b/graph-lib/graph/map_old.rkt @@ -1,10 +1,9 @@ #lang debug typed/racket (require (for-syntax racket/syntax - syntax/stx syntax/parse syntax/parse/experimental/template - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) (for-meta 2 racket/base racket/syntax) diff --git a/graph-lib/graph/queue.lp2.rkt b/graph-lib/graph/queue.lp2.rkt index 3aea62b7..bdf593d7 100644 --- a/graph-lib/graph/queue.lp2.rkt +++ b/graph-lib/graph/queue.lp2.rkt @@ -375,7 +375,7 @@ was a tag requested. (module main typed/racket (require (for-syntax syntax/parse racket/syntax - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) "../lib/low.rkt" racket/set racket/format) diff --git a/graph-lib/graph/rewrite-type.lp2.rkt b/graph-lib/graph/rewrite-type.lp2.rkt index 430f03b6..32e7c1f7 100644 --- a/graph-lib/graph/rewrite-type.lp2.rkt +++ b/graph-lib/graph/rewrite-type.lp2.rkt @@ -630,11 +630,10 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and (require (for-syntax syntax/parse racket/syntax - syntax/stx racket/format syntax/parse/experimental/template racket/sequence - "../lib/low-untyped.rkt" + (submod "../lib/low.rkt" untyped) (only-in "../type-expander/type-expander.lp2.rkt" expand-type) "meta-struct.rkt") diff --git a/graph-lib/graph/structure.lp2.rkt b/graph-lib/graph/structure.lp2.rkt index 2c8bec77..d2a63ca8 100644 --- a/graph-lib/graph/structure.lp2.rkt +++ b/graph-lib/graph/structure.lp2.rkt @@ -591,12 +591,10 @@ chances that we could write a definition for that identifier. syntax/parse/experimental/template mzlib/etc racket/struct-info - syntax/stx racket/sequence ;; in-syntax on older versions: ;;;unstable/sequence - "../lib/low-untyped.rkt" - "../lib/low/multiassoc-syntax.rkt" + (submod "../lib/low.rkt" untyped) "meta-struct.rkt") "../lib/low.rkt" "../type-expander/type-expander.lp2.rkt" diff --git a/graph-lib/graph/variant.lp2.rkt b/graph-lib/graph/variant.lp2.rkt index bda4d95d..6eab4ccf 100644 --- a/graph-lib/graph/variant.lp2.rkt +++ b/graph-lib/graph/variant.lp2.rkt @@ -281,7 +281,7 @@ number of name collisions. (require (for-syntax syntax/parse syntax/parse/experimental/template racket/syntax - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) "../lib/low.rkt" "../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.lp2.rkt" diff --git a/graph-lib/lib/doc.rkt b/graph-lib/lib/doc.rkt index 3a96839c..2f914649 100644 --- a/graph-lib/lib/doc.rkt +++ b/graph-lib/lib/doc.rkt @@ -10,7 +10,7 @@ (require scriblib/render-cond) -;(require "low-untyped.rkt") +;(require "(submod low.rkt untyped)") ;(#lang reader "scribble-custom/lp2.rkt" #:lang typed/racket) ;; http://lists.racket-lang.org/users/archive/2015-January/065752.html diff --git a/graph-lib/lib/doc/template.lp2.rkt b/graph-lib/lib/doc/template.lp2.rkt index c330dad8..365db714 100644 --- a/graph-lib/lib/doc/template.lp2.rkt +++ b/graph-lib/lib/doc/template.lp2.rkt @@ -50,8 +50,8 @@ scribble, see (module main typed/racket (require (for-syntax syntax/parse racket/syntax - "../../lib/low-untyped.rkt") - "../../lib/low-untyped.rkt") + (submod "../../lib/low.rkt" untyped)) + (submod "../../lib/low.rkt" untyped)) (provide foo) diff --git a/graph-lib/lib/low.rkt b/graph-lib/lib/low.rkt index 56cbf14f..18831c6e 100644 --- a/graph-lib/lib/low.rkt +++ b/graph-lib/lib/low.rkt @@ -1,1517 +1,31 @@ #lang typed/racket - -(provide degub) -(: degub (∀ (T) (→ T T))) -(define (degub x) (display "degub:") (displayln x) x) - -;; ==== low/threading.rkt - -;; raco pkg install alexis-util -;; or: -;; raco pkg install threading -(require alexis/util/threading - (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 [_ ♦] [<~_ <~♦] [~>_ ~>♦])) - -;; ==== low/typed-untyped-module.rkt ==== - -(require typed/untyped-utils) -(provide define-half-typed-module typed/untyped-prefix define-modules) - -;; define-half-typed-module -(define-syntax-rule (typed-module (m t u typed-#lang untyped-#lang) . body) - (begin - (module m typed-#lang - ; PROBLEM: require submod ".." won't work because we're one level deeper. - ;(module t typed-language . body) - ;(module u untyped-language . body) - . body))) - -(define-syntax-rule (untyped-module (m t u typed-#lang untyped-#lang) . body) - (begin - (module m untyped-#lang - ; PROBLEM: require submod ".." won't work because we're one level deeper. - ;(module t typed-language . body) - ;(module u untyped-language . body) - . body))) - -(define-typed/untyped-identifier define-half-typed-module - typed-module - untyped-module) - -#| ;; test: should work in no-check but not in typed: -(define-half-typed-module moo typed/racket typed/racket/no-check - (: foo One) - (define foo 2)) -|# - -;; typed/untyped-prefix -(define-syntax-rule - (typed-typed/untyped-prefix [typed-prefix ...] [untyped-prefix ...] . rest) - (typed-prefix ... . rest)) - -(define-syntax-rule - (untyped-typed/untyped-prefix [typed-prefix ...] [untyped-prefix ...] . rest) - (untyped-prefix ... . rest)) - -(define-typed/untyped-identifier typed/untyped-prefix - typed-typed/untyped-prefix - untyped-typed/untyped-prefix) - -#| -;; 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 -(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)) -|# - -;; ==== low/require-provide.rkt ==== - -(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)) - -;; ==== low/syntax-parse.rkt ==== - -(define-modules ([no-submodule] - [syntax-parse-extensions-untyped typed/racket/no-check]) - (require syntax/parse - syntax/parse/define - (for-syntax racket/base - racket/syntax)) +(require "low/typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (require "low/typed-untyped.rkt") + (provide (all-from-out "low/typed-untyped.rkt")) - (provide define-syntax/parse - λ/syntax-parse - ~maybe - ~lit - ~or-bug) - - (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])))) - -;; If you include this as a file, you need to do: -;(begin-for-syntax (provide stx)) -;; It's not provided by (all-from-out) :-( - -;; ==== low/check-type-and-equal.rkt ==== -;; TODO: this won't expand types in the ann. - -(define-half-typed-module (my-typed-rackunit typed untyped - typed/racket typed/racket/no-check) - (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 (submod ".." syntax-parse-extensions-untyped);define-syntax-parse.rkt - (for-syntax syntax/parse - syntax/parse/experimental/template)) - - (provide check-equal?: - check-not-equal?:) - - (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" (list actual - 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" (list actual - 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)))))))) - -(require/provide 'my-typed-rackunit) - -;; ==== low/typed-fixnum.rkt === - -(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)) - -;; ==== Rest ==== -(provide hash-set** - map+fold - cons→values - (rename-out [cons→values cons->values]) - nameof - first-value second-value third-value fourth-value fifth-value - sixth-value seventh-value eighth-value ninth-value tenth-value - ∘ - … - …+ - stx-list - stx-e - stx-pair - template/debug - quasitemplate/debug - ;string-set! - ;string-copy! - ;string-fill! - with-output-file - in-tails - in-heads - in-split - in-split* - *in-split - my-in-syntax - indexof - replace-first - Syntax-Listof - check-duplicate-identifiers - generate-temporary - sequence-length>= - in-last?) - -(require (only-in racket - [compose ∘] - [... …]) - (only-in syntax/parse - [...+ …+])) - -(require (for-syntax syntax/parse syntax/parse/experimental/template)) - -(: 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)))) - - -(define #:∀ (A B) (cons→values [x : (Pairof A B)]) (values (car x) (cdr x))) - -(: 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)))) - -(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)) - -(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)))) - -(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-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))) - -(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))) - -(require syntax/parse/experimental/template) -(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))])) - -(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))])) - -;; 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/provide 'm-meta-eval) - -(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)) - -#| -(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))))])) - -(: 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)))) - -;; 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))) - -(: 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)))))) - -;; 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 #'())) - -(: 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? (→ (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)) - - -(: check-duplicate-identifiers (→ (Syntaxof (Listof (Syntaxof Symbol))) - Boolean)) -(define (check-duplicate-identifiers ids) - (if (check-duplicate-identifier (my-in-syntax ids)) #t #f)) - -(require/typed racket/syntax [generate-temporary (→ Any Identifier)]) - -(require syntax/parse/define) -(provide define-simple-macro) - -(require racket/match) -(provide (all-from-out racket/match) - (rename-out [match-lambda match-λ] - [match-lambda* match-λ*] - [match-lambda** match-λ**])) - - -;; ==== ids.rkt ==== - -(define-modules ([no-submodule] [ids-untyped typed/racket/no-check]) - (provide format-ids - hyphen-ids - format-temp-ids - #|t/gen-temp|# - define-temp-ids) - - (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 - - (require "sequences.rkt" - #|"../low.rkt"|#) ;; my-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 ;(submod "..") - ;"test-framework.rkt" - (for-syntax racket/syntax - (submod ".." ids-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)))) - -(module m-t/gen-temp racket - (require syntax/parse - syntax/parse/experimental/template) - - (provide t/gen-temp) - - (define-template-metafunction (t/gen-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-t/gen-temp) -(provide (rename-out [t/gen-temp &])) - -;; ==== syntax.rkt ==== - -(provide syntax-cons-property - stx-assoc - cdr-stx-assoc - stx-map-nested - identifier-length - identifier->string - (rename-out [identifier->string identifier→string])) - -(: syntax-cons-property (∀ (A) (→ (Syntaxof A) Symbol Any (Syntaxof A)))) -(define (syntax-cons-property stx key v) - (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))) -#| -(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-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-cons - -(module m-stx-untyped racket - (require syntax/stx) - (provide stx-cons #;stx-drop-last) - - (define (stx-cons a b) #`(#,a . #,b))) - -(typed/untyped-prefix - [module m-stx-typed typed/racket - (require (only-in typed/racket/unsafe unsafe-require/typed)) - (unsafe-require/typed (submod ".." m-stx-untyped) - [stx-cons (∀ (A B) - (→ (Syntaxof A) - (Syntaxof B) - (Syntaxof (Pairof (Syntaxof A) - (Syntaxof B)))))]) - (provide stx-cons)] - [module m-stx-typed typed/racket/no-check - (require (submod ".." m-stx-untyped)) - (provide stx-cons)]) - -(require/provide 'm-stx-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-pair? - -(: stx-pair? (→ Any Boolean : (Syntaxof Any))) -(define (stx-pair? x) (if (syntax? x) #t #f)) - -;; stx-drop-last - -(: stx-drop-last (∀ (A) (→ (Syntaxof (Listof A)) (Syntaxof (Listof A))))) -(define (stx-drop-last l) - (if (and (stx-pair? l) (stx-pair? (stx-cdr l))) - (stx-cons (stx-car l) (stx-drop-last (stx-cdr l))) - #'())) - -; (require/typed racket/base [(assoc assoc3) -; (∀ (a b) (→ Any (Listof (Pairof a b)) -; (U False (Pairof a b))))]) -(require/typed racket/base - [(assoc assoc3) - (∀ (a b c) (case→ [→ Any - (Listof (Pairof a b)) - (U False (Pairof a b))] - [-> c - (Listof (Pairof a b)) - (→ c a Boolean) - (U False (Pairof a b))]))]) - -(: 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 (assoc3 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))))) - -;; ==== generate-indices ==== - -(: generate-indices (∀ (T) (case→ (→ Integer (Syntax-Listof T) - (Listof Integer)) - (→ (Syntax-Listof T) - (Listof Nonnegative-Integer))))) - -(provide generate-indices) - -(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)])) - -;; ==== set.rkt ==== - -(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))) - -;; ==== type-inference-helpers.rkt ==== - -(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)) - -;; ==== percent.rkt ==== - -(provide % define%) -#|(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 )])) -|# - -;; ==== low/repeat-stx.rkt === - -(define-modules ([no-submodule] [repeat-stx-untyped typed/racket/no-check]) - (require syntax/stx - (for-syntax racket/base - racket/syntax - syntax/parse)) - - (provide repeat-stx) - - (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 repeat-stx-test racket - (require (submod ".." repeat-stx-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) ())))) - -(module+ test - (require (submod ".." repeat-stx-test))) - -;; ==== low/test-framework.rkt ==== -(require (for-syntax syntax/parse) - (for-syntax (submod "." syntax-parse-extensions-untyped)) - (for-syntax (submod "." repeat-stx-untyped)) - typed/rackunit) - -(provide check-equal?-classes - check-equal?-classes:) - -(: 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 …) …))) - -;; ==== low/typed-not-implemented-yet.rkt ==== - -(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))))])) - -;; ==== low/cond-let.rkt ==== - -(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 …)))])) - -;; ==== end ==== \ No newline at end of file + ;(require/provide (typed/untyped "low/fixnum.rkt" …)) + (require/provide-typed/untyped + "low/misc.rkt" + "low/require-provide.rkt" + "low/fixnum.rkt" + "low/typed-rackunit.rkt" + "low/typed-rackunit-extensions.rkt" + "low/syntax-parse.rkt" + "low/threading.rkt" + "low/aliases.rkt" + "low/sequence.rkt" + "low/repeat-stx.rkt" + "low/stx.rkt" + "low/list.rkt" + "low/values.rkt" + "low/ids.rkt" + "low/generate-indices.rkt" + "low/set.rkt" + "low/type-inference-helpers.rkt" + "low/percent.rkt" + "low/not-implemented-yet.rkt" + "low/cond-let.rkt" + "low/multiassoc-syntax.rkt" + "low/tmpl-multiassoc-syntax.rkt" + "low/logn-id.rkt")) diff --git a/graph-lib/lib/low/aliases.rkt b/graph-lib/lib/low/aliases.rkt new file mode 100644 index 00000000..15637845 --- /dev/null +++ b/graph-lib/lib/low/aliases.rkt @@ -0,0 +1,26 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide (all-from-out racket/match) + ∘ + … + …+ + match-λ + match-λ* + match-λ** + generate-temporary) + + (require racket/match) + + (require (only-in racket + [compose ∘] + [... …]) + (only-in syntax/parse + [...+ …+])) + + (require (only-in racket/match + [match-lambda match-λ] + [match-lambda* match-λ*] + [match-lambda** match-λ**])) + + (require/typed racket/syntax [generate-temporary (→ Any Identifier)])) diff --git a/graph-lib/lib/low/cond-let.rkt b/graph-lib/lib/low/cond-let.rkt new file mode 100644 index 00000000..e92ffb39 --- /dev/null +++ b/graph-lib/lib/low/cond-let.rkt @@ -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 …)))]))) \ No newline at end of file diff --git a/graph-lib/lib/low/fixnum.rkt b/graph-lib/lib/low/fixnum.rkt new file mode 100644 index 00000000..8b707b23 --- /dev/null +++ b/graph-lib/lib/low/fixnum.rkt @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/generate-indices.rkt b/graph-lib/lib/low/generate-indices.rkt new file mode 100644 index 00000000..9cce1fcc --- /dev/null +++ b/graph-lib/lib/low/generate-indices.rkt @@ -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)]))) \ No newline at end of file diff --git a/graph-lib/lib/low/ids.rkt b/graph-lib/lib/low/ids.rkt new file mode 100644 index 00000000..f3f465f0 --- /dev/null +++ b/graph-lib/lib/low/ids.rkt @@ -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" + "aliases.rkt") + (begin-for-syntax (require "typed-untyped.rkt") + (require-typed/untyped "aliases.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)]) + (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))))) \ No newline at end of file diff --git a/graph-lib/lib/low/list.rkt b/graph-lib/lib/low/list.rkt new file mode 100644 index 00000000..ebbdbf27 --- /dev/null +++ b/graph-lib/lib/low/list.rkt @@ -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))))) \ No newline at end of file diff --git a/graph-lib/lib/low/logn-id.rkt b/graph-lib/lib/low/logn-id.rkt index 093e011a..24b36cf0 100644 --- a/graph-lib/lib/low/logn-id.rkt +++ b/graph-lib/lib/low/logn-id.rkt @@ -1,77 +1,82 @@ #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 "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide define-logn-ids) - (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})])) + (require (for-syntax syntax/parse + racket/syntax + racket/function + racket/match + syntax/stx) + "typed-untyped.rkt") - (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 (if-typed ((make-predicate #,sa) v-cache) + #,(format-id sa "~a?" sa)) + #,(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)) \ No newline at end of file + (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))) \ No newline at end of file diff --git a/graph-lib/lib/low/misc.rkt b/graph-lib/lib/low/misc.rkt new file mode 100644 index 00000000..8760ceb4 --- /dev/null +++ b/graph-lib/lib/low/misc.rkt @@ -0,0 +1,53 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (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))))])))) \ No newline at end of file diff --git a/graph-lib/lib/low/multiassoc-syntax.rkt b/graph-lib/lib/low/multiassoc-syntax.rkt index e11beb64..551a5715 100644 --- a/graph-lib/lib/low/multiassoc-syntax.rkt +++ b/graph-lib/lib/low/multiassoc-syntax.rkt @@ -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 "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide multiassoc-syntax + cdr-assoc-syntax + assoc-syntax) + + (require "typed-untyped.rkt") + (require-typed/untyped "aliases.rkt" + "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)))) diff --git a/graph-lib/lib/low/not-implemented-yet.rkt b/graph-lib/lib/low/not-implemented-yet.rkt new file mode 100644 index 00000000..9196a9d8 --- /dev/null +++ b/graph-lib/lib/low/not-implemented-yet.rkt @@ -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))))]))) \ No newline at end of file diff --git a/graph-lib/lib/low/percent.rkt b/graph-lib/lib/low/percent.rkt new file mode 100644 index 00000000..9204bc4e --- /dev/null +++ b/graph-lib/lib/low/percent.rkt @@ -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 )])) + |#) \ No newline at end of file diff --git a/graph-lib/lib/low/repeat-stx.rkt b/graph-lib/lib/low/repeat-stx.rkt new file mode 100644 index 00000000..a49364b8 --- /dev/null +++ b/graph-lib/lib/low/repeat-stx.rkt @@ -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) ())))) \ No newline at end of file diff --git a/graph-lib/lib/low/require-provide.rkt b/graph-lib/lib/low/require-provide.rkt new file mode 100644 index 00000000..f424047b --- /dev/null +++ b/graph-lib/lib/low/require-provide.rkt @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/sequence.rkt b/graph-lib/lib/low/sequence.rkt new file mode 100644 index 00000000..db16cff9 --- /dev/null +++ b/graph-lib/lib/low/sequence.rkt @@ -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))])) + |#)) \ No newline at end of file diff --git a/graph-lib/lib/low/set.rkt b/graph-lib/lib/low/set.rkt new file mode 100644 index 00000000..76842491 --- /dev/null +++ b/graph-lib/lib/low/set.rkt @@ -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)))) \ No newline at end of file diff --git a/graph-lib/lib/low/stx.rkt b/graph-lib/lib/low/stx.rkt new file mode 100644 index 00000000..b74a817f --- /dev/null +++ b/graph-lib/lib/low/stx.rkt @@ -0,0 +1,407 @@ +#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 + (all-from-out syntax/stx)) + + (require "typed-untyped.rkt") + (require-typed/untyped "sequence.rkt") + + (require syntax/stx) + + ;; 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) + (if-typed + ((make-predicate (U (Syntaxof Null) Null)) v) + (or (null? v) (and (syntax? v) (null? (syntax-e v)))))) + + (module+ test + (check-equal? (stx-null? #f) #f) + (check-equal? (stx-null? 'a) #f) + (check-equal? (stx-null? '()) #t) + (check-equal? (stx-null? #'()) #t) + (check-equal? (stx-null? #''()) #f) + (check-equal? (stx-null? #'a) #f)) + + (: stx-pair? (→ Any Boolean : (U (Pairof Any Any) + (Syntaxof (Pairof Any Any))))) + (define (stx-pair? v) + (if-typed + ((make-predicate (U (Pairof Any Any) + (Syntaxof (Pairof Any Any)))) + v) + (or (pair? v) (and (syntax? v) (pair? (syntax-e 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 (if-typed ((make-predicate (Syntaxof Any)) l) (syntax? 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))) + |#) \ No newline at end of file diff --git a/graph-lib/lib/low/syntax-parse.rkt b/graph-lib/lib/low/syntax-parse.rkt new file mode 100644 index 00000000..344773fd --- /dev/null +++ b/graph-lib/lib/low/syntax-parse.rkt @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/threading.rkt b/graph-lib/lib/low/threading.rkt new file mode 100644 index 00000000..7b682267 --- /dev/null +++ b/graph-lib/lib/low/threading.rkt @@ -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 [_ ♦] [<~_ <~♦] [~>_ ~>♦]))) \ No newline at end of file diff --git a/graph-lib/lib/low/tmpl-multiassoc-syntax.rkt b/graph-lib/lib/low/tmpl-multiassoc-syntax.rkt new file mode 100644 index 00000000..1f02e39b --- /dev/null +++ b/graph-lib/lib/low/tmpl-multiassoc-syntax.rkt @@ -0,0 +1,25 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide tmpl-cdr-assoc-syntax + (rename-out [tmpl-cdr-assoc-syntax !cdr-assoc])) + + (module m-tmpl-cdr-assoc-syntax racket + (provide tmpl-cdr-assoc-syntax) + + (require syntax/parse + syntax/parse/experimental/template + (submod "stx.rkt" untyped) + (submod "multiassoc-syntax.rkt" untyped) + (submod "aliases.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)) \ No newline at end of file diff --git a/graph-lib/lib/low/type-inference-helpers.rkt b/graph-lib/lib/low/type-inference-helpers.rkt new file mode 100644 index 00000000..9db433d0 --- /dev/null +++ b/graph-lib/lib/low/type-inference-helpers.rkt @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/typed-rackunit-extensions.rkt b/graph-lib/lib/low/typed-rackunit-extensions.rkt new file mode 100644 index 00000000..6b6094c8 --- /dev/null +++ b/graph-lib/lib/low/typed-rackunit-extensions.rkt @@ -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 …) …)))) \ No newline at end of file diff --git a/graph-lib/lib/low/typed-rackunit.rkt b/graph-lib/lib/low/typed-rackunit.rkt new file mode 100644 index 00000000..a6a9007b --- /dev/null +++ b/graph-lib/lib/low/typed-rackunit.rkt @@ -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)))))))) \ No newline at end of file diff --git a/graph-lib/lib/low/typed-untyped.rkt b/graph-lib/lib/low/typed-untyped.rkt new file mode 100644 index 00000000..0cea441d --- /dev/null +++ b/graph-lib/lib/low/typed-untyped.rkt @@ -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 'require) (#,(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)) + |#) \ No newline at end of file diff --git a/graph-lib/lib/low/values.rkt b/graph-lib/lib/low/values.rkt new file mode 100644 index 00000000..ddf84921 --- /dev/null +++ b/graph-lib/lib/low/values.rkt @@ -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)))) \ No newline at end of file diff --git a/graph-lib/lib/low-untyped.rkt b/graph-lib/lib/old_low-untyped.rkt similarity index 100% rename from graph-lib/lib/low-untyped.rkt rename to graph-lib/lib/old_low-untyped.rkt diff --git a/graph-lib/lib/sequences.rkt b/graph-lib/lib/sequences.rkt deleted file mode 100644 index a382011b..00000000 --- a/graph-lib/lib/sequences.rkt +++ /dev/null @@ -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))])) -|# - diff --git a/graph-lib/lib/test-define-temp-ids.rkt b/graph-lib/lib/test-define-temp-ids.rkt index 087aab44..b12ee56f 100644 --- a/graph-lib/lib/test-define-temp-ids.rkt +++ b/graph-lib/lib/test-define-temp-ids.rkt @@ -1,5 +1,5 @@ #lang racket -(require "low-untyped.rkt") +(require (submod "low.rkt" untyped)) (with-syntax ([((foo ...) ...) #'((aa bb cc) (x1 x2))]) (define-temp-ids "___~a.truc" ((foo ...) ...) #:first-base fst) diff --git a/graph-lib/lib/untyped.rkt b/graph-lib/lib/untyped.rkt index cfa38bdc..0073233b 100644 --- a/graph-lib/lib/untyped.rkt +++ b/graph-lib/lib/untyped.rkt @@ -1,4 +1,4 @@ #lang typed/racket -(require "low-untyped.rkt") +(require "low.rkt") (require/provide "untyped/for-star-list-star.rkt") diff --git a/graph-lib/main.rkt b/graph-lib/main.rkt index 05ca1c0d..3301216c 100644 --- a/graph-lib/main.rkt +++ b/graph-lib/main.rkt @@ -9,50 +9,6 @@ (require "graph/variant.lp2.rkt") |# -(define-type from (List (Pairof Number Boolean) - (Listof (U Number (Pairof Number String))))) -(define-type to (List (Pairof String Boolean) - (Listof (U String (Pairof String String))))) - -(: convert1 (→ from to)) -(define (convert1 v) - (match v [(list a b) (list (convert2 a) (convert3 b))])) - -(: convert2 (→ (Pairof Number Boolean) (Pairof String Boolean))) -(define (convert2 v) - (match v [(cons a b) (cons (convert4 a) (convert5 b))])) - -(: convert3 (→ (Listof (U Number (Pairof Number String))) - (Listof (U String (Pairof String String))))) -(define (convert3 v) - (match v [(? list?) (map convert6 v)])) - -(: convert4 (→ Number String)) -(define (convert4 v) - (match v [(? number?) (format "~a" v)])) - -(: convert5 (→ Boolean Boolean)) -(define (convert5 v) - (match v [(? boolean?) v])) - -(: convert6 (→ (U Number (Pairof Number String)) - (U String (Pairof String String)))) -(define (convert6 v) - (match v - [(? number?) (format "~a" v)] - [(? pair?) (cons (convert4 (car v)) (convert7 (cdr v)))])) - -(: convert7 (→ String String)) -(define (convert7 v) - (match v [(? string?) v])) - -(require typed/rackunit) -(check-equal? (convert1 '((123 . #t) (1 2 (3 . "b") 4 (5 . "x") 6))) - '(("123" . #t) ("1" "2" ("3" . "b") "4" ("5" . "x") "6"))) - - - - #| (define-type from (List (Pairof Number Boolean) (Listof Number))) (define-type to (List (Pairof String Boolean) (Listof String))) diff --git a/graph-lib/make/dependency-graph.rkt b/graph-lib/make/dependency-graph.rkt index 51855cae..cda8da38 100644 --- a/graph-lib/make/dependency-graph.rkt +++ b/graph-lib/make/dependency-graph.rkt @@ -62,6 +62,7 @@ (define excluded '(typed/racket + typed/racket/no-check racket/base racket scribble/lp/lang/lang2)) @@ -119,7 +120,6 @@ (define (tag-pair dep) (append (if (equal? (cdr dep) "lib/low.rkt") '(lib/low) '()) - (if (equal? (cdr dep) "lib/low-untyped.rkt") '(lib/low) '()) (if (equal? (categorize-main-module (car dep)) (categorize-main-module (cdr dep))) '(submodule) '()) (if (lib? (cdr dep)) '(lib) '()))) diff --git a/graph-lib/make/make.rkt b/graph-lib/make/make.rkt index 2e6cb69c..1b763e23 100644 --- a/graph-lib/make/make.rkt +++ b/graph-lib/make/make.rkt @@ -137,6 +137,7 @@ (run! `(,(find-executable-path-or-fail "raco") "make" + "-v" "-j" "5" ,@rkt-files)) diff --git a/graph-lib/type-expander/type-expander.lp2.rkt b/graph-lib/type-expander/type-expander.lp2.rkt index 8a941af3..e1765d52 100644 --- a/graph-lib/type-expander/type-expander.lp2.rkt +++ b/graph-lib/type-expander/type-expander.lp2.rkt @@ -1069,10 +1069,9 @@ in a separate module (that will be used only by macros, so it will be written in (module expander racket (require racket syntax/parse - syntax/stx racket/format syntax/id-table - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) (require (for-template typed/racket)) @@ -1101,7 +1100,7 @@ We can finally define the overloaded forms, as well as the extra racket/syntax syntax/parse syntax/parse/experimental/template - "../lib/low-untyped.rkt") + (submod "../lib/low.rkt" untyped)) "../lib/low.rkt") (require (submod ".." expander)) @@ -1159,7 +1158,7 @@ And, last but not least, we will add a @tc[test] module. "../lib/low.rkt" (for-syntax (submod ".." expander) racket/list - "../lib/low-untyped.rkt")) + (submod "../lib/low.rkt" untyped)))