diff --git a/.github/workflows/benchmarks.yml b/.github/workflows/benchmarks.yml index d3db3cd7..a8645f32 100644 --- a/.github/workflows/benchmarks.yml +++ b/.github/workflows/benchmarks.yml @@ -25,7 +25,7 @@ jobs: run: make install-sdk - name: Run benchmark shell: 'bash --noprofile --norc -eo pipefail {0}' - run: make report-benchmarks | tee benchmarks.txt + run: make performance-report | tee benchmarks.txt - name: Store benchmark result uses: benchmark-action/github-action-benchmark@v1 with: diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 321a1016..d844ca17 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -14,7 +14,7 @@ jobs: fail-fast: true matrix: racket-variant: ['BC', 'CS'] - racket-version: ['8.3', 'stable'] + racket-version: ['8.5', 'stable'] experimental: [false] include: - racket-version: 'current' diff --git a/Makefile b/Makefile index 6f620b06..2d3d3d9e 100644 --- a/Makefile +++ b/Makefile @@ -7,12 +7,15 @@ DEPS-FLAGS=--check-pkg-deps --unused-pkg-deps help: @echo "install - install package along with dependencies" + @echo "install-sdk - install the SDK which includes developer tools" @echo "remove - remove package" + @echo "remove-sdk - remove SDK; this will not remove SDK dependencies" @echo "build - Compile libraries" @echo "build-docs - Build docs" @echo "build-standalone-docs - Build self-contained docs that could be hosted somewhere" @echo "build-all - Compile libraries, build docs, and check dependencies" @echo "clean - remove all build artifacts" + @echo "clean-sdk - remove all build artifacts in SDK paths" @echo "check-deps - check dependencies" @echo "test - run tests" @echo "test-with-errortrace - run tests with error tracing" @@ -27,6 +30,8 @@ help: @echo " definitions" @echo " macro" @echo " util" + @echo " expander" + @echo " compiler" @echo " probe" @echo " Note: As probe is not in qi-lib, it isn't part of" @echo " the tests run in the 'test' target." @@ -37,9 +42,14 @@ help: @echo "docs - view docs in a browser" @echo "profile - Run comprehensive performance benchmarks" @echo "profile-competitive - Run competitive benchmarks" - @echo "profile-forms - Run benchmarks for individual Qi forms" + @echo "profile-local - Run benchmarks for individual Qi forms" + @echo "profile-nonlocal - Run nonlocal benchmarks exercising many components at once" @echo "profile-selected-forms - Run benchmarks for Qi forms by name (command only)" - @echo "report-benchmarks - Run benchmarks for Qi forms and produce results for use in CI" + @echo "performance-report - Run benchmarks for Qi forms and produce results for use in CI and for measuring regression" + @echo " For use in regression: make performance-report > /path/to/before.json" + @echo "performance-regression-report - Run benchmarks for Qi forms against a reference report." + @echo " make performance-regression-report REF=/path/to/before.json" + # Primarily for use by CI. # Installs dependencies as well as linking this as a package. @@ -82,6 +92,9 @@ build-standalone-docs: clean: raco setup --fast-clean --pkgs $(PACKAGE-NAME)-{lib,test,doc,probe} +clean-sdk: + raco setup --fast-clean --pkgs $(PACKAGE-NAME)-sdk + # Primarily for use by CI, after make install -- since that already # does the equivalent of make setup, this tries to do as little as # possible except checking deps. @@ -89,29 +102,37 @@ check-deps: raco setup --no-docs $(DEPS-FLAGS) $(PACKAGE-NAME) # Suitable for both day-to-day dev and CI +# Note: we don't test qi-doc since there aren't any tests there atm +# and it also seems to make things extremely slow to include it. test: - raco test -exp $(PACKAGE-NAME)-{lib,test,doc,probe} + raco test -exp $(PACKAGE-NAME)-{lib,test,probe} test-flow: - racket $(PACKAGE-NAME)-test/tests/flow.rkt + racket -y $(PACKAGE-NAME)-test/tests/flow.rkt test-on: - racket $(PACKAGE-NAME)-test/tests/on.rkt + racket -y $(PACKAGE-NAME)-test/tests/on.rkt test-threading: - racket $(PACKAGE-NAME)-test/tests/threading.rkt + racket -y $(PACKAGE-NAME)-test/tests/threading.rkt test-switch: - racket $(PACKAGE-NAME)-test/tests/switch.rkt + racket -y $(PACKAGE-NAME)-test/tests/switch.rkt test-definitions: - racket $(PACKAGE-NAME)-test/tests/definitions.rkt + racket -y $(PACKAGE-NAME)-test/tests/definitions.rkt test-macro: - racket $(PACKAGE-NAME)-test/tests/macro.rkt + racket -y $(PACKAGE-NAME)-test/tests/macro.rkt test-util: - racket $(PACKAGE-NAME)-test/tests/util.rkt + racket -y $(PACKAGE-NAME)-test/tests/util.rkt + +test-expander: + racket -y $(PACKAGE-NAME)-test/tests/expander.rkt + +test-compiler: + racket -y $(PACKAGE-NAME)-test/tests/compiler.rkt test-probe: raco test -exp $(PACKAGE-NAME)-probe @@ -159,20 +180,27 @@ cover: coverage-check coverage-report cover-coveralls: raco cover -b -f coveralls -p $(PACKAGE-NAME)-{lib,test} -profile-forms: - echo "Profiling forms..." - racket $(PACKAGE-NAME)-sdk/profile/forms.rkt +profile-local: + racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt + +profile-loading: + racket $(PACKAGE-NAME)-sdk/profile/loading/report.rkt profile-selected-forms: - @echo "Use 'racket profile/forms.rkt' directly, with -f form-name for each form." + @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt' directly, with -s form-name for each form." profile-competitive: - echo "Running competitive benchmarks..." - racket $(PACKAGE-NAME)-sdk/profile/competitive.rkt + cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report-competitive.rkt + +profile-nonlocal: + cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report-intrinsic.rkt -l qi + +profile: profile-local profile-nonlocal profile-loading -profile: profile-competitive profile-forms +performance-report: + @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -f json -report-benchmarks: - @racket $(PACKAGE-NAME)-sdk/profile/report.rkt +performance-regression-report: + @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) -.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-selected-forms profile-competitive profile report-benchmarks +.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-expander test-compiler test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-local profile-loading profile-selected-forms profile-competitive profile-nonlocal profile performance-report performance-regression-report diff --git a/qi-doc/scribblings/eval.rkt b/qi-doc/scribblings/eval.rkt new file mode 100644 index 00000000..790f784c --- /dev/null +++ b/qi-doc/scribblings/eval.rkt @@ -0,0 +1,30 @@ +#lang racket/base + +(provide make-eval-for-docs) + +(require racket/sandbox) + +(define (make-eval-for-docs . exprs) + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (apply make-evaluator + 'racket/base + '(require qi + qi/probe + (only-in racket/list range first rest) + racket/format + racket/string + (only-in racket/function curry) + (for-syntax syntax/parse + racket/base)) + '(define (sqr x) + (* x x)) + '(define ->string number->string) + exprs))))) diff --git a/qi-doc/scribblings/field-guide.scrbl b/qi-doc/scribblings/field-guide.scrbl index 9ef88d0d..5f940704 100644 --- a/qi-doc/scribblings/field-guide.scrbl +++ b/qi-doc/scribblings/field-guide.scrbl @@ -2,24 +2,12 @@ @require[scribble/manual scribble-abbrevs/manual scribble/example - racket/sandbox + "eval.rkt" @for-label[qi qi/probe racket]] -@(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - qi/probe - (only-in racket/list range) - racket/string - (for-syntax syntax/parse - racket/base)) - '(define (sqr x) - (* x x))))) +@(define eval-for-docs (make-eval-for-docs)) @title{Field Guide} @@ -41,6 +29,10 @@ Decompose your @tech{flow} into its smallest components, and name each so that t A journeyman of one's craft -- a woodworker, electrician, or a plumber, say -- always goes to work with a trusty toolbox that contains the tools of the trade, some perhaps even of their own design. An electrician, for instance, may have a voltage tester, a multimeter, and a continuity tester in her toolbox. Although these are "debugging" tools, they aren't just for identifying bugs -- by providing rapid feedback, they enable her to explore and find creative solutions quickly and reliably. It's the same with Qi. Learn to use the @seclink["Debugging"]{debugging tools}, and use them often. +@subsection{Be Intentional About Effects} + +Qi encourages a style that avoids "accidental" effects. A flow should either be pure (that is, it should be free of "side effects" such as printing to the screen or writing to a file), or its entire purpose should be to fulfill a side effect. It is considered inadvisable to have a function with sane inputs and outputs (resembling a pure function) that also performs a side effect. It would be better to decouple the effect from the rest of your function (@seclink["Use_Small_Building_Blocks"]{splitting it into smaller functions}, as necessary) and perform the effect explicitly via the @racket[effect] form, or otherwise escape from Qi using something like @racket[esc] (note that @seclink["Identifiers"]{function identifiers} used in a flow context are implicitly @racket[esc]aped) in order to perform the effect. This will ensure that there are no surprises with regard to @seclink["Order_of_Effects"]{order of effects}. + @section{Debugging} There are three prominent debugging strategies which may be used independently or in tandem -- @seclink["Using_Side_Effects"]{side effects}, @seclink["Using_a_Probe"]{probing}, and @seclink["Using_Fixtures"]{fixtures}. @@ -208,6 +200,17 @@ Methodical use of @racket[gen] together with the @seclink["Using_a_Probe"]{probe @bold{Common example}: Syntax patterns are defined in the @seclink["stxparse" #:doc '(lib "syntax/scribblings/syntax.scrbl")]{syntax/parse} library. If you are using them in Qi macros, you will need to @racket[(require syntax/parse)] at the appropriate phase level. +@subsubsection{Identifier's Binding is Ambiguous} + +@codeblock{ +; count: identifier's binding is ambiguous +; in: count +} + +@bold{Meaning}: The @tech/guide{expander} attempted to resolve a @tech/reference{reference} and found more than one possible @tech/reference{binding}. + +@bold{Common example}: Having a Racket function in scope that has the same name as a Qi form, and attempting to use this @seclink["Identifiers"]{unqualified identifier} as a flow. To avoid the issue, rename the Racket function to something else, or use an explicit @racket[esc] to indicate the Racket binding. + @subsubsection{Not Defined as Syntax Class} @codeblock{ @@ -322,7 +325,7 @@ But in an idle moment, this clever shortcut may tempt you: (~> (3) ((get-f 1))) ] -That is, since Qi typically interprets parenthesized expressions as @seclink["Templates_and_Partial_Application"]{partial application templates}, you might expect that this would pass the value @racket[3] to the function resulting from @racket[(get-f 1)]. In fact, that isn't what happens, and an error is raised instead. As there is only one datum within the outer pair of parentheses in @racket[((get-f 1))], the usual interpretation as partial application would not be useful, and could even lead to unexpected behavior (at least, with the current implementation that uses Racket's @racket[curry]). So instead, Qi attempts to interpret the expression as written, that is, as if it were wrapped in @racket[esc]. As a result, it attempts to evaluate @racket[((get-f 1))] and expects to receive a value that can be used as a @tech{flow} here. If, as in the above expression, the function resulting from @racket[(get-f 1)] expects a single argument, this is now an error as it is being invoked with none. +That is, since Qi typically interprets parenthesized expressions as @seclink["Templates_and_Partial_Application"]{partial application templates}, you might expect that this would pass the value @racket[3] to the function resulting from @racket[(get-f 1)]. In fact, that isn't what happens, and an error is raised instead. As there is only one datum within the outer pair of parentheses in @racket[((get-f 1))], the usual interpretation as partial application would not typically be useful, so Qi opts to treat it as invalid syntax. One way to dodge this is by using an explicit template: @@ -332,14 +335,6 @@ One way to dodge this is by using an explicit template: This works in most cases, but it has different semantics than the version using @racket[esc], as that version evaluates the escaped expression first to yield the @tech{flow} that will be applied to inputs, while this one only evaluates the (up to that point, incomplete) expression when it is actually invoked with arguments. In the most common cases there will be no difference to the result, but if the flow is invoked multiple times (for instance, if it were first defined as @racket[(define-flow my-flow (☯ ((get-f 1) _)))]), then the expression too would be evaluated multiple times, producing different functions each time. This may be computationally more expensive than using @racket[esc], and also, if either @racket[get-f] or the function it produces is stateful in any way (for instance, if it is a @hyperlink["https://www.gnu.org/software/guile/manual/html_node/Closure.html"]{closure} or if there is any randomness involved), then this version would also produce different results than the @racket[esc] version. -Another way to do it is to simply promote the expression out of the nest: - -@racketblock[ - (~> (3) (get-f 1)) - ] - -Now, you might, once again, expect this to be treated as a partial application template, so that this would be equivalent to @racket[(get-f 3 1)] and would raise an error. But in fact, since the expression @racket[(get-f 1)] happens to be fully qualified with all the arguments it needs, the currying employed under the hood to implement partial application in this case @seclink["Using_Racket_to_Define_Flows"]{evaluates to a function result right away}. This then receives the value @racket[3], and consequently, this expression produces the correct result. - So in sum, it's perhaps best to rely on @racket[esc] in such cases to be as explicit as possible about what you mean, rather than rely on quirks of the implementation that are revealed at this boundary between two languages. @subsubsection{Mutable Values Defy the Laws of Flows} @@ -359,6 +354,18 @@ Worse still, even though this computation raises an error, we find that the orig So in general, use mutable values with caution. Such values can be useful as side effects, for instance to capture some idea of statefulness, perhaps keeping track of the number of times a @tech{flow} was invoked. But they should generally not be used as inputs to a flow, especially if they are to be mutated. +@subsubsection{Order of Effects} + + Qi flows may exhibit a different order of effects (in the functional programming sense) than equivalent Racket functions. + +Consider the Racket expression: @racket[(map sqr (filter odd? (list 1 2 3 4 5)))]. As this invokes @racket[odd?] on all of the elements of the input list, followed by @racket[sqr] on all of the elements of the intermediate list, if we imagine that @racket[odd?] and @racket[sqr] print their inputs as a side effect before producing their results, then executing this program would print the numbers in the sequence @racket[1,2,3,4,5,1,3,5]. + +The equivalent Qi flow is @racket[(~> ((list 1 2 3 4 5)) (filter odd?) (map sqr))]. As this sequence is @seclink["Don_t_Stop_Me_Now"]{"deforested" by Qi's compiler} to avoid multiple passes over the data and the memory overhead of intermediate representations, it invokes the functions in sequence @emph{on each element} rather than @emph{on all of the elements of each list in turn}. The printed sequence with Qi would be @racket[1,1,2,3,3,4,5,5]. + +Yet, either implementation produces the same output: @racket[(list 1 9 25)]. + +So, to reiterate, while the output of Qi flows will be the same as the output of equivalent Racket expressions, they may nevertheless exhibit a different order of effects. + @section{Effectively Using Feedback Loops} @racket[feedback] is Qi's most powerful looping form, useful for arbitrary recursion. As it encourages quite a different way of thinking than Racket's usual looping forms do, here are some tips on "grokking" it. diff --git a/qi-doc/scribblings/forms.scrbl b/qi-doc/scribblings/forms.scrbl index 2a32f724..0656c592 100644 --- a/qi-doc/scribblings/forms.scrbl +++ b/qi-doc/scribblings/forms.scrbl @@ -2,21 +2,11 @@ @require[scribble/manual scribble-abbrevs/manual scribble/example - racket/sandbox - @for-label[qi + "eval.rkt" + @for-label[(only-space-in qi qi) racket]] -@(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range first rest) - racket/string) - '(define (sqr x) - (* x x))))) - +@(define eval-for-docs (make-eval-for-docs)) @(define diagram-eval (make-base-eval)) @(diagram-eval '(require metapict)) @;{For an explanation of the special handling of `__` in code blocks and in examples, see racket/scribble#369} @@ -346,11 +336,15 @@ Note that the symbol form uses Unicode @code{0x2225} corresponding to LaTeX's @c @deftogether[( @defform[(== flo ...)] @defform[(relay flo ...)] +@defidform[#:link-target? #f ==] +@defidform[#:link-target? #f relay] )]{ Compose @tech{flows} in parallel, so that inputs are passed through the corresponding @racket[flo]'s individually. The number of @racket[flo]s must be the same as the number of runtime inputs. In the common case of @code{1 × 1} @racket[flo]s (i.e. where the flows each accept one input and produce one output), the number of outputs will be the same as the number of inputs, but as @seclink["What_is_a_Flow_"]{flows can be nonlinear}, this is not necessarily the case in general. + When used in identifier form simply as @racket[==], it behaves identically to @racket[><]. + See also the field guide entry on the @seclink["Bindings_are_an_Alternative_to_Nonlinearity"]{relationship between bindings and nonlinearity}. @examples[ @@ -568,11 +562,14 @@ A form of generalized @racket[sieve], passing all the inputs that satisfy each (loop condition-flo map-flo)] @defform[#:link-target? #f (loop map-flo)] + @defidform[#:link-target? #f loop] )]{ A simple loop for structural recursion on the input values, this applies @racket[map-flo] to the first input on each successive iteration and recurses on the remaining inputs, combining these using @racket[combine-flo] to yield the result as long as the inputs satisfy @racket[condition-flo]. When the inputs do not satisfy @racket[condition-flo], @racket[return-flo] is applied to the inputs to yield the result at that terminating step. If the condition is satisfied and there are no further values, the loop terminates naturally. If unspecified, @racket[condition-flo] defaults to @racket[#t], @racket[combine-flo] defaults to @racket[_], and @racket[return-flo] defaults to @racket[⏚]. + When used in identifier form simply as @racket[loop], this behaves the same as the fully qualified version, except that the flows parametrizing the loop are expected as the initial four inputs (in the same order), and the data inputs being acted upon are expected to follow. + @examples[ #:eval eval-for-docs ((☯ (loop (* 2))) 1 2 3) @@ -801,7 +798,7 @@ A form of generalized @racket[sieve], passing all the inputs that satisfy each As @racket[displayln] expects a single input, you'd need to use @racket[(>< displayln)] for this side-effect in general. - If you are interesting in using @racket[effect] to debug a flow, see the section on @secref["Debugging" #:doc '(lib "qi/scribblings/qi.scrbl")] in the field guide for more strategies. + If you are interested in using @racket[effect] to debug a flow, see the section on @secref["Debugging" #:doc '(lib "qi/scribblings/qi.scrbl")] in the field guide for more strategies. @examples[ #:eval eval-for-docs @@ -819,10 +816,61 @@ A form of generalized @racket[sieve], passing all the inputs that satisfy each ] } +@section{Binding} + +@defform[(as v ...)]{ + A @tech{flow} that binds an identifier @racket[v] to the input value. If there are many input values, than there should be as many identifiers as there are inputs. + +@examples[ + #:eval eval-for-docs + ((☯ (~> (-< (~> list (as vs)) + +) + (~a "The sum of " vs " is " _))) + 1 2) + ((☯ (~> (-< + count) + (as total number) + (/ total number))) + 1 2 3 4 5) + ] +} + +@subsection{Variable Scope} + +In general, bindings are scoped to the @emph{outermost} threading form (as the first example above shows), and may be referenced downstream. We will use @racket[(gen v)] as an example of a flow referencing a binding, to illustrate variable scope. + +@codeblock{(~> 5 (as v) (gen v))} + +... produces @racket[5]. + +A @racket[tee] junction binds downstream flows in a containing threading form, with later tines shadowing earlier tines. + +@codeblock{(~> (-< (~> 5 (as v)) (~> 6 (as v))) (gen v))} + +... produces @racket[6]. + +A @racket[relay] binds downstream flows in a containing threading form, with later tines shadowing earlier tines. + +@codeblock{(~> (gen 5 6) (== (as v) (as v)) (gen v))} + +... produces @racket[6]. + +In an @racket[if] conditional form, variables bound in the condition bind the consequent and alternative flows, and do not bind downstream flows. + +@codeblock{(if (~> ... (as v) ...) (gen v) (gen v))} + +Analogously, in a @racket[switch], variables bound in each condition bind the corresponding consequent flow. + +@codeblock{(switch [(~> ... (as v) ...) (gen v)] + [(~> ... (as v) ...) (gen v)])} + +As @racket[switch] compiles to @racket[if], technically, earlier conditions bind all later switch clauses (and are shadowed by them), but this is considered an incidental implementation detail. Like @racket[if], @racket[switch] bindings are unavailable downstream. + @section{Identifiers} Identifiers in a flow context are interpreted as @tech/reference{variables} whose @tech/reference{values} are expected to be @seclink["lambda" #:doc '(lib "scribblings/guide/guide.scrbl")]{functions}. In other words, any named function may be used directly as a @tech{flow}. +More precisely, for instance, @racket[add1] in a flow context is equivalent to @racket[(esc add1)]. + @examples[ #:eval eval-for-docs ((☯ +) 1 2 3) diff --git a/qi-doc/scribblings/interface.scrbl b/qi-doc/scribblings/interface.scrbl index ac461cf6..768349ec 100644 --- a/qi-doc/scribblings/interface.scrbl +++ b/qi-doc/scribblings/interface.scrbl @@ -2,22 +2,12 @@ @require[scribble/manual scribble-abbrevs/manual scribble/example - racket/sandbox + "eval.rkt" @for-label[qi racket syntax/parse/define]] -@(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range) - racket/string) - '(define ->string number->string) - '(define (sqr x) - (* x x))))) +@(define eval-for-docs (make-eval-for-docs)) @title{Language Interface} @@ -42,6 +32,7 @@ The core entry-point to Qi from the host language is the form @racket[☯]. In a collect (esc expr) (clos flow-expr) + (as identifier ...) (one-of? expr ...) (all flow-expr) (any flow-expr) @@ -73,17 +64,21 @@ The core entry-point to Qi from the host language is the form @racket[☯]. In a (thread-right flow-expr ...) X crossover + == (== flow-expr ...) + relay (relay flow-expr ...) (==* flow-expr ...) (relay* flow-expr ...) + -< (-< flow-expr ...) + tee (tee flow-expr ...) fanout - (fanout number) + (fanout nat) feedback - (feedback number flow-expr) - (feedback number (then flow-expr) flow-expr) + (feedback nat flow-expr) + (feedback nat (then flow-expr) flow-expr) (feedback (while flow-expr) flow-expr) (feedback (while flow-expr) (then flow-expr) flow-expr) count @@ -99,7 +94,7 @@ The core entry-point to Qi from the host language is the form @racket[☯]. In a (select index ...) (block index ...) (bundle (index ...) flow-expr flow-expr) - (group number flow-expr flow-expr) + (group nat flow-expr flow-expr) sieve (sieve flow-expr flow-expr flow-expr) (partition [flow-expr flow-expr] ...) @@ -132,23 +127,33 @@ The core entry-point to Qi from the host language is the form @racket[☯]. In a (ε flow-expr flow-expr) (effect flow-expr flow-expr) apply - literal - (quote value) - (quasiquote value) - (quote-syntax value) - (syntax value) (qi:* expr ...) (expr expr ... __ expr ...) (expr expr ... _ expr ...) (expr expr ...) - expr] + literal + identifier] + [literal boolean + char + string + bytes + number + regexp + byte-regexp + vector-literal + box-literal + prefab-literal + (quote value) + (quasiquote value) + (quote-syntax value) + (syntax value)] [expr a-racket-expression] [index exact-positive-integer?] - [number exact-nonnegative-integer?] + [nat exact-nonnegative-integer?] [switch-expr [flow-expr flow-expr] [flow-expr (=> flow-expr)] [else flow-expr]] - [literal a-racket-literal] + [identifier a-racket-identifier] [value a-racket-value])] @defform[(flow flow-expr)] )]{ @@ -354,19 +359,6 @@ The second way is if you want to describe a @tech{flow} using the host language (~> (3 5) add-two) ] -Finally, note that the following case works: - -@examples[ - #:eval eval-for-docs - (define (get-flow v) - (☯ (~> sqr (+ v)))) - (~> (5) (get-flow 3)) - ] - -You might expect here that the expression @racket[(get-flow 3)] would be treated as a @seclink["Templates_and_Partial_Application"]{partial application template}, so that the value @racket[5] would be provided to it as @racket[(get-flow 5 3)], resulting in an error. The reason this isn't what happens is that the partial application behavior in Qi when no argument positions have been indicated is implemented using currying rather than as a template application, and Racket's @racket[curry] and @racket[curryr] functions happen to evaluate to a result immediately if the maximum expected arguments have been provided. Thus, in this case, the @racket[(get-flow 3)] expression is first evaluated to produce a resulting @tech{flow} which then receives the value @racket[5]. - -So, function applications where all of the arguments are provided syntactically, and which produce functions as their result, may be used as if they were simple function identifiers, and @racket[esc] may be left out. - @subsection{Using Racket Macros as Flows} Flows are expected to be @seclink["What_is_a_Flow_"]{functions}, and so you cannot naively use a macro as a flow. But there are many ways in which you can. If you'd just like to use such a macro in a one-off manner, see @secref["Converting_a_Macro_to_a_Flow"] for an ad hoc way to do this. But a simpler and more complete way in many cases is to first register the macro (or any number of such macros) using @racket[define-qi-foreign-syntaxes] prior to use. diff --git a/qi-doc/scribblings/intro.scrbl b/qi-doc/scribblings/intro.scrbl index a8968f8c..280c2f0c 100644 --- a/qi-doc/scribblings/intro.scrbl +++ b/qi-doc/scribblings/intro.scrbl @@ -2,20 +2,11 @@ @require[scribble/manual scribble-abbrevs/manual scribble/example - racket/sandbox + "eval.rkt" @for-label[qi racket]] -@(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range) - racket/string) - '(define (sqr x) - (* x x))))) +@(define eval-for-docs (make-eval-for-docs)) @title{Introduction and Usage} @@ -82,5 +73,7 @@ For macros, we cannot use them naively as @tech{flows} because macros expect all The threading library also provides numerous shorthands for common cases, many of which don't have equivalents in Qi -- if you'd like to have these, please @hyperlink["https://github.com/drym-org/qi/issues/"]{create an issue} on the source repo to register your interest. +Finally, by virtue of having an optimizing compiler, Qi also offers performance benefits in some cases, including for use of sequences of standard functional operations on lists like @racket[map] and @racket[filter], which in Qi avoid constructing intermediate representations along the way to generating the final result. + @close-eval[eval-for-docs] @(set! eval-for-docs #f) diff --git a/qi-doc/scribblings/macros.scrbl b/qi-doc/scribblings/macros.scrbl index 2e5ed500..96550aa4 100644 --- a/qi-doc/scribblings/macros.scrbl +++ b/qi-doc/scribblings/macros.scrbl @@ -2,23 +2,13 @@ @require[scribble/manual scribble-abbrevs/manual scribble/example - racket/sandbox + "eval.rkt" @for-label[qi racket syntax/parse syntax/parse/define]] -@(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range first rest) - (for-syntax syntax/parse racket/base) - racket/string) - '(define (sqr x) - (* x x))))) +@(define eval-for-docs (make-eval-for-docs)) @title[#:tag "Qi_Macros"]{Qi Macros} diff --git a/qi-doc/scribblings/principles.scrbl b/qi-doc/scribblings/principles.scrbl index 1a76a95d..0922eb7f 100644 --- a/qi-doc/scribblings/principles.scrbl +++ b/qi-doc/scribblings/principles.scrbl @@ -43,10 +43,18 @@ The way to group values, if we need grouping, is to collect them into a data structure (e.g. a list) using a collection prism, @racket[▽]. In the case of a tee junction, the way to differentiate between values coming from each channel of the junction is for the channels to individually @racket[collect] their values at the end. That way, the values that are the output of the composite flow are lists generated individually by the various channels of the flow. -@section{Everything is a Function} +@section[#:tag "Everything_is_a_Function"]{Counting Flows} Everything in Qi is a @seclink["lambda" #:doc '(lib "scribblings/guide/guide.scrbl")]{function}. Programs are functions, they are made up of functions. Even @seclink["Literals"]{literals} are interpreted as functions generating them. +Consider this example: + +@codeblock{ + (~> sqr (-< add1 5) *) +} + +There are six @tech{flows} here, in all: the entire one, each component of the thread, and each component of the tee junction. + @section{Flowy Logic} Qi's design is inspired by buddhist śūnyatā logic. To understand it holistically would require a history lesson to put the sunyata development in context, and that would be quite a digression. But in essence, sunyata is about transcension of context or viewpoint. A viewpoint is identifiable with a logical span of possibilities (@emph{catuṣkoṭi}) in terms of which assertions may be made. Sunyata is the rejection of @emph{all} of the available logical possibilities, thus transcending the very framing of the problem (this is signified by the word @emph{mu} in Zen). This kind of transcension could suggest alternative points of view, but more precisely, does not indicate a point of view (which isn't the same as being ambivalent or even agnostic). This idea has implications not just for formal logical systems but also for everyday experience and profound metaphysical questions alike. diff --git a/qi-doc/scribblings/tutorial.scrbl b/qi-doc/scribblings/tutorial.scrbl index 054fcc9c..bd2e2db3 100644 --- a/qi-doc/scribblings/tutorial.scrbl +++ b/qi-doc/scribblings/tutorial.scrbl @@ -2,22 +2,12 @@ @require[scribble/manual scribble-abbrevs/manual scribble/example - racket/sandbox + "eval.rkt" scribble-math/dollar @for-label[qi racket]] -@(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range) - (only-in racket/function curry) - racket/string) - '(define (sqr x) - (* x x))))) +@(define eval-for-docs (make-eval-for-docs)) @title{Tutorial} diff --git a/qi-doc/scribblings/using-qi.scrbl b/qi-doc/scribblings/using-qi.scrbl index 24f2eee0..fe4981ad 100644 --- a/qi-doc/scribblings/using-qi.scrbl +++ b/qi-doc/scribblings/using-qi.scrbl @@ -188,6 +188,28 @@ This separates the input list into its component values, produces a @racket[1] c This succinctness is possible because Qi reaps the twin benefits of (1) working directly with values (and not just collections of values), and (2) Racket's support for variadic functions that accept any number of inputs (in this case, @racket[+]). +@section{Don't Stop Me Now} + +When you're interested in functionally transforming lists using operations like @racket[map], @racket[filter], @racket[foldl] and @racket[foldr], Qi is a good choice because its optimizing compiler eliminates intermediate representations that would ordinarily be constructed in computing the result of such a sequence, resulting in significant performance gains in some cases. + +For example, consider the Racket function: + +@codeblock{ + (define (filter-map vs) + (map sqr (filter odd? vs))) +} + +In evaluating this sequence, the input list is traversed to produce the result of @racket[filter], which is a list that is traversed one more time to produce another list that is the result of @racket[map]. + +The equivalent Qi flow is: + +@codeblock{ + (define-flow filter-map + (~> (filter odd?) (map sqr))) +} + +Here, under the hood, each element of the input list is processed one at a time, with both of these functions being invoked on it in sequence, and then the output list is constructed by accumulating these individual results. This ensures that no intermediate lists are constructed along the way and that the input list is traversed just once -- a standard optimization technique called "stream fusion" or "deforestation." The Qi version produces the same result as the Racket code above, but it can be both faster as well as more memory-efficient, especially on large input lists. Note however that if the functions used in @racket[filter] and @racket[map] are not @emph{pure}, that is, if they perform side effects like printing to the screen or writing to a file, then the Qi flow would exhibit a different @seclink["Order_of_Effects"]{order of effects} than the Racket version. + @section{Curbing Curries and Losing Lambdas} Since flows are just functions, you can use them anywhere that you would normally use a function. In particular, they are often a clearer alternative to using @hyperlink["https://en.wikipedia.org/wiki/Currying"]{currying} or @seclink["lambda" #:doc '(lib "scribblings/guide/guide.scrbl")]{lambdas}. For instance, to double every number in a list, we could do: diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index af6f067a..773d3332 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -1,19 +1,19 @@ #lang racket/base (provide flow - ☯) + ☯ + (all-from-out "flow/extended/expander.rkt") + (all-from-out "flow/extended/forms.rkt")) -(require syntax/parse/define - (prefix-in fancy: fancy-app) - racket/function - (only-in racket/list - make-list) +(require syntax-spec-v1 (for-syntax racket/base syntax/parse (only-in "private/util.rkt" - report-syntax-error) - "flow/expander.rkt") - "flow/compiler.rkt" + report-syntax-error)) + "flow/extended/expander.rkt" + "flow/core/compiler.rkt" + "flow/extended/forms.rkt" + (for-syntax "flow/extended/util.rkt") (only-in "private/util.rkt" define-alias)) @@ -33,14 +33,19 @@ module, defined after the flow macro. They are all invoked as needed in the flow macro. |# -(define-syntax-parser flow - [(_ onex) ((compose compile-flow expand-flow) #'onex)] - ;; a non-flow - [(_) #'values] - ;; error handling catch-all - [(_ expr0 expr ...+) - (report-syntax-error - 'flow - (syntax->datum #'(expr0 expr ...)) - "(flow flo)" - "flow expects a single flow specification, but it received many.")]) +(syntax-spec + (host-interface/expression + (flow f:closed-floe ...) + (syntax-parse #'(f ...) + [(f) (compile-flow #'f)] + ;; a non-flow + [() #'values] + ;; error handling catch-all + [(expr0 expr ...+) + (report-syntax-error + (datum->syntax this-syntax + (cons 'flow + (map prettify-flow-syntax + (syntax->list this-syntax)))) + "(flow flo)" + "flow expects a single flow specification, but it received many.")]))) diff --git a/qi-lib/flow/aux-syntax.rkt b/qi-lib/flow/aux-syntax.rkt index 0f12421d..e5cf653a 100644 --- a/qi-lib/flow/aux-syntax.rkt +++ b/qi-lib/flow/aux-syntax.rkt @@ -17,6 +17,9 @@ expr:number expr:regexp expr:byte-regexp + expr:vector-literal + expr:box-literal + expr:prefab-literal ;; We'd like to treat quoted forms as literals as well. This ;; includes symbols, and would also include, for instance, ;; syntactic specifications of flows, since flows are @@ -30,17 +33,26 @@ (define-syntax-class subject #:attributes (args arity) - (pattern - (arg:expr ...) - #:with args #'(arg ...) - #:attr arity (length (syntax->list #'args)))) + (pattern (arg:expr ...) + #:with args #'(arg ...) + #:attr arity (length (syntax->list #'args)))) (define-syntax-class clause - (pattern - expr:expr)) + (pattern expr:expr)) -(define-syntax-class (starts-with pfx) - (pattern - i:id #:when (string-prefix? (symbol->string - (syntax-e #'i)) pfx))) +(define-syntax-class vector-literal + (pattern #(_ ...))) +(define-syntax-class box-literal + (pattern #&v)) + +(define-syntax-class prefab-literal + (pattern e:expr + #:when (prefab-struct-key (syntax-e #'e)))) + +(define-syntax-class (starts-with pfx) + (pattern i:id + #:when (string-prefix? + (symbol->string + (syntax-e #'i)) + pfx))) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt deleted file mode 100644 index 823452eb..00000000 --- a/qi-lib/flow/compiler.rkt +++ /dev/null @@ -1,639 +0,0 @@ -#lang racket/base - -(provide (for-syntax compile-flow)) - -(require (for-syntax racket/base - syntax/parse - racket/match - (only-in racket/list - make-list) - "syntax.rkt" - "aux-syntax.rkt" - (only-in "../private/util.rkt" - report-syntax-error)) - (only-in "../macro.rkt" - qi-macro? - qi-macro-transformer) - "impl.rkt" - racket/function - (prefix-in fancy: fancy-app) - (only-in racket/list - make-list)) - -(begin-for-syntax - ;; note: this does not return compiled code but instead, - ;; syntax whose expansion compiles the code - (define (compile-flow stx) - #`(qi0->racket #,(optimize-flow stx))) - - (define (optimize-flow stx) - stx)) - -(define-syntax (qi0->racket stx) - (syntax-parse (cadr (syntax->list stx)) - ;; Check first whether the form is a macro. If it is, expand it. - ;; This is prioritized over other forms so that extensions may - ;; override built-in Qi forms. - [stx - #:with (~or* (m:id expr ...) m:id) #'stx - #:do [(define space-m ((make-interned-syntax-introducer 'qi) #'m))] - #:when (qi-macro? (syntax-local-value space-m (λ () #f))) - #:with expanded (syntax-local-apply-transformer - (qi-macro-transformer (syntax-local-value space-m)) - space-m - 'expression - #f - #'stx) - #'(qi0->racket expanded)] - - ;;; Special words - [((~datum one-of?) v:expr ...) - #'(compose - ->boolean - (curryr member (list v ...)))] - [((~datum all) onex:clause) - #`(give (curry andmap (qi0->racket onex)))] - [((~datum any) onex:clause) - #'(give (curry ormap (qi0->racket onex)))] - [((~datum none) onex:clause) - #'(qi0->racket (not (any onex)))] - [((~datum and) onex:clause ...) - #'(conjoin (qi0->racket onex) ...)] - [((~datum or) onex:clause ...) - #'(disjoin (qi0->racket onex) ...)] - [((~datum not) onex:clause) - #'(negate (qi0->racket onex))] - [((~datum gen) ex:expr ...) - #'(λ _ (values ex ...))] - [(~or* (~datum NOT) (~datum !)) - #'not] - [(~or* (~datum AND) (~datum &)) - #'all?] - [(~or* (~datum OR) (~datum ∥)) - #'any?] - [(~datum NOR) - #'(qi0->racket (~> OR NOT))] - [(~datum NAND) - #'(qi0->racket (~> AND NOT))] - [(~datum XOR) - #'parity-xor] - [(~datum XNOR) - #'(qi0->racket (~> XOR NOT))] - [e:and%-form (and%-parser #'e)] - [e:or%-form (or%-parser #'e)] - [(~datum any?) #'any?] - [(~datum all?) #'all?] - [(~datum none?) #'none?] - [(~or* (~datum ▽) (~datum collect)) - #'list] - [e:sep-form (sep-parser #'e)] - - ;;; Core routing elements - - [(~or* (~datum ⏚) (~datum ground)) - #'(qi0->racket (select))] - [((~or* (~datum ~>) (~datum thread)) onex:clause ...) - #`(compose . #,(reverse - (syntax->list - #'((qi0->racket onex) ...))))] - [e:right-threading-form (right-threading-parser #'e)] - [(~or* (~datum X) (~datum crossover)) - #'(qi0->racket (~> ▽ reverse △))] - [((~or* (~datum ==) (~datum relay)) onex:clause ...) - #'(relay (qi0->racket onex) ...)] - [((~or* (~datum ==*) (~datum relay*)) onex:clause ... rest-onex:clause) - (with-syntax ([len #`#,(length (syntax->list #'(onex ...)))]) - #'(qi0->racket (group len (== onex ...) rest-onex) ))] - [((~or* (~datum -<) (~datum tee)) onex:clause ...) - #'(λ args - (apply values - (append (values->list - (apply (qi0->racket onex) args)) - ...)))] - [e:select-form (select-parser #'e)] - [e:block-form (block-parser #'e)] - [((~datum bundle) (n:number ...) - selection-onex:clause - remainder-onex:clause) - #'(qi0->racket (-< (~> (select n ...) selection-onex) - (~> (block n ...) remainder-onex)))] - [e:group-form (group-parser #'e)] - - ;;; Conditionals - - [e:if-form (if-parser #'e)] - [((~datum when) condition:clause - consequent:clause) - #'(qi0->racket (if condition consequent ⏚))] - [((~datum unless) condition:clause - alternative:clause) - #'(qi0->racket (if condition ⏚ alternative))] - [e:switch-form (switch-parser #'e)] - [e:sieve-form (sieve-parser #'e)] - [e:partition-form (partition-parser #'e)] - [((~datum gate) onex:clause) - #'(qi0->racket (if onex _ ⏚))] - - ;;; Exceptions - - [e:try-form (try-parser #'e)] - - ;;; High level circuit elements - - ;; aliases for inputs - [e:input-alias (input-alias-parser #'e)] - - ;; common utilities - [(~datum count) - #'(λ args (length args))] - [(~datum live?) - #'(λ args (not (null? args)))] - [((~datum rectify) v:expr ...) - #'(qi0->racket (if live? _ (gen v ...)))] - - ;; high level routing - [e:fanout-form (fanout-parser #'e)] - [e:feedback-form (feedback-parser #'e)] - [(~datum inverter) - #'(qi0->racket (>< NOT))] - [e:side-effect-form (side-effect-parser #'e)] - - ;;; Higher-order flows - - ;; map, filter, and fold - [e:amp-form (amp-parser #'e)] - [e:pass-form (pass-parser #'e)] - [e:fold-left-form (fold-left-parser #'e)] - [e:fold-right-form (fold-right-parser #'e)] - - ;; looping - [e:loop-form (loop-parser #'e)] - [((~datum loop2) pred:clause mapex:clause combex:clause) - #'(letrec ([loop2 (qi0->racket (if pred - (~> (== (-< cdr - (~> car mapex)) _) - (group 1 _ combex) - loop2) - 2>))]) - loop2)] - - ;; towards universality - [(~datum apply) - #'call] - [e:clos-form (clos-parser #'e)] - - ;;; Miscellaneous - - ;; escape hatch for racket expressions or anything - ;; to be "passed through" - [((~datum esc) ex:expr) - #'ex] - - ;; backwards compat macro extensibility via Racket macros - [((~var ext-form (starts-with "qi:")) expr ...) - #'(ext-form expr ...)] - - ;; a literal is interpreted as a flow generating it - [e:literal (literal-parser #'e)] - - ;; Partial application with syntactically pre-supplied arguments - ;; in a blanket template - [e:blanket-template-form (blanket-template-form-parser #'e)] - - ;; Fine-grained template-based application - ;; This handles templates that indicate a specific number of template - ;; variables (i.e. expected arguments). The semantics of template-based - ;; application here is fulfilled by the fancy-app module. In order to use - ;; it, we simply use the #%app macro provided by fancy-app instead of the - ;; implicit one used for function application in racket/base. - ;; "prarg" = "pre-supplied argument" - [(prarg-pre ... (~datum _) prarg-post ...) - #'(fancy:#%app prarg-pre ... _ prarg-post ...)] - - ;; Pre-supplied arguments without a template - [(natex prarg ...+) - ;; we use currying instead of templates when a template hasn't - ;; explicitly been indicated since in such cases, we cannot - ;; always infer the appropriate arity for a template (e.g. it - ;; may change under composition within the form), while a - ;; curried function will accept any number of arguments - #:do [(define chirality (syntax-property this-syntax 'chirality))] - (if (and chirality (eq? chirality 'right)) - #'(curry natex prarg ...) - #'(curryr natex prarg ...))] - - ;; pass-through (identity flow) - [(~datum _) #'values] - - ;; literally indicated function identifier - [natex:expr #'natex])) - -;; The form-specific parsers, which are delegated to from -;; the qi0->racket macro: - -#| -A note on error handling: - -Some forms, in addition to handling legitimate syntax, also have -catch-all versions that exist purely to provide a helpful message -indicating a syntax error. We do this since a priori the qi0->racket macro -would ignore syntax that doesn't match any pattern. Yet, for all of -these named forms, we know that (or at least, it is prudent to assume -that) the user intended to employ that particular form of the DSL. So -instead of allowing it to fall through for interpretation as Racket -code, which would yield potentially inscrutable errors, the catch-all -forms allow us to provide appropriate error messages at the level of -the DSL. - -|# - -(begin-for-syntax - (define-syntax-class disjux-clause ; "juxtaposed" disjoin - #:attributes (parsed) - (pattern - (~datum _) - #:with parsed #'false.) - (pattern - onex:clause - #:with parsed #'onex)) - - (define-syntax-class conjux-clause ; "juxtaposed" conjoin - #:attributes (parsed) - (pattern - (~datum _) - #:with parsed #'true.) - (pattern - onex:clause - #:with parsed #'onex)) - - (define (and%-parser stx) - (syntax-parse stx - [(_ onex:conjux-clause ...) - #'(qi0->racket (~> (== onex.parsed ...) - all?))])) - - (define (or%-parser stx) - (syntax-parse stx - [(_ onex:disjux-clause ...) - #'(qi0->racket (~> (== onex.parsed ...) - any?))])) - - (define (make-right-chiral stx) - (syntax-property stx 'chirality 'right)) - - (define-syntax-class right-threading-clause - (pattern - onex:clause - #:with chiral (make-right-chiral #'onex))) - - (define (right-threading-parser stx) - ;; right-threading is just normal threading - ;; but with a syntax property attached to - ;; the components indicating the chirality - (syntax-parse stx - [(_ onex:right-threading-clause ...) - #'(qi0->racket (~> onex.chiral ...))])) - - (define (sep-parser stx) - (syntax-parse stx - [_:id - #'(qi0->racket (if list? - (apply values _) - (raise-argument-error '△ - "list?" - _)))] - [(_ onex:clause) - #'(λ (v . vs) - ((qi0->racket (~> △ (>< (apply (qi0->racket onex) _ vs)))) v))])) - - (define (select-parser stx) - (syntax-parse stx - [(_ n:number ...) #'(qi0->racket (-< (esc (arg n)) ...))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'select - (syntax->datum #'(arg ...)) - "(select ...)")])) - - (define (block-parser stx) - (syntax-parse stx - [(_ n:number ...) - #'(qi0->racket (~> (esc (except-args n ...)) - △))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'block - (syntax->datum #'(arg ...)) - "(block ...)")])) - - (define (group-parser stx) - (syntax-parse stx - [(_ n:expr - selection-onex:clause - remainder-onex:clause) - #'(loom-compose (qi0->racket selection-onex) - (qi0->racket remainder-onex) - n)] - [_:id - #'(λ (n selection-flo remainder-flo . vs) - (apply (qi0->racket (group n selection-flo remainder-flo)) vs))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'group - (syntax->datum #'(arg ...)) - "(group racket> racket>)")])) - - (define (switch-parser stx) - (syntax-parse stx - [(_) #'(qi0->racket _)] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause)) - #'(qi0->racket consequent-gate)] - [(_ [(~datum else) alternative:clause]) - #'(qi0->racket alternative)] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause) - [(~datum else) alternative:clause]) - #'(qi0->racket (~> consequent-gate alternative))] - [(_ [condition0:clause ((~datum =>) consequent0:clause ...)] - [condition:clause consequent:clause] - ...) - ;; we split the flow ahead of time to avoid evaluating - ;; the condition more than once - #'(qi0->racket (~> (-< condition0 _) - (if 1> - (~> consequent0 ...) - (group 1 ⏚ - (switch [condition consequent] - ...)))))] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause) - [condition0:clause ((~datum =>) consequent0:clause ...)] - [condition:clause consequent:clause] - ...) - ;; both divert as well as => clauses. Here, the divert clause - ;; operates on the original inputs, not including the result - ;; of the condition flow. - ;; as before, we split the flow ahead of time to avoid evaluating - ;; the condition more than once - #'(qi0->racket (~> (-< (~> condition-gate condition0) _) - (if 1> - (~> (group 1 _ consequent-gate) - consequent0 ...) - (group 1 ⏚ - (switch (divert condition-gate consequent-gate) - [condition consequent] - ...)))))] - [(_ [condition0:clause consequent0:clause] - [condition:clause consequent:clause] - ...) - #'(qi0->racket (if condition0 - consequent0 - (switch [condition consequent] - ...)))] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause) - [condition0:clause consequent0:clause] - [condition:clause consequent:clause] - ...) - #'(qi0->racket (if (~> condition-gate condition0) - (~> consequent-gate consequent0) - (switch (divert condition-gate consequent-gate) - [condition consequent] - ...)))])) - - (define (sieve-parser stx) - (syntax-parse stx - [(_ condition:clause - sonex:clause - ronex:clause) - #'(qi0->racket (-< (~> (pass condition) sonex) - (~> (pass (not condition)) ronex)))] - [_:id - #'(λ (condition sonex ronex . args) - (apply (qi0->racket (-< (~> (pass condition) sonex) - (~> (pass (not condition)) ronex))) - args))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'sieve - (syntax->datum #'(arg ...)) - "(sieve racket> racket> racket>)")])) - - (define (partition-parser stx) - (syntax-parse stx - [(_:id) - #'(qi0->racket ground)] - [(_ [cond:clause body:clause]) - #'(qi0->racket (~> (pass cond) body))] - [(_ [cond:clause body:clause] ...+) - #:with c+bs #'(list (cons (qi0->racket cond) (qi0->racket body)) ...) - #'(qi0->racket (~>> (partition-values c+bs)))])) - - (define (try-parser stx) - (syntax-parse stx - [(_ flo - [error-condition-flo error-handler-flo] - ...+) - #'(λ args - (with-handlers ([(qi0->racket error-condition-flo) - (λ (e) - ;; TODO: may be good to support reference to the - ;; error via a binding / syntax parameter - (apply (qi0->racket error-handler-flo) args))] - ...) - (apply (qi0->racket flo) args)))] - [(_ arg ...) - (report-syntax-error 'try - (syntax->datum #'(arg ...)) - "(try [error-predicate-flo error-handler-flo] ...)")])) - - (define (input-alias-parser stx) - (syntax-parse stx - [(~datum 1>) - #'(qi0->racket (select 1))] - [(~datum 2>) - #'(qi0->racket (select 2))] - [(~datum 3>) - #'(qi0->racket (select 3))] - [(~datum 4>) - #'(qi0->racket (select 4))] - [(~datum 5>) - #'(qi0->racket (select 5))] - [(~datum 6>) - #'(qi0->racket (select 6))] - [(~datum 7>) - #'(qi0->racket (select 7))] - [(~datum 8>) - #'(qi0->racket (select 8))] - [(~datum 9>) - #'(qi0->racket (select 9))])) - - (define (if-parser stx) - (syntax-parse stx - [(_ consequent:clause - alternative:clause) - #'(λ (f . args) - (if (apply f args) - (apply (qi0->racket consequent) args) - (apply (qi0->racket alternative) args)))] - [(_ condition:clause - consequent:clause - alternative:clause) - #'(λ args - (if (apply (qi0->racket condition) args) - (apply (qi0->racket consequent) args) - (apply (qi0->racket alternative) args)))])) - - (define (fanout-parser stx) - (syntax-parse stx - [_:id #'repeat-values] - [(_ n:number) - ;; a slightly more efficient compile-time implementation - ;; for literally indicated N - #`(λ args - (apply values - (append #,@(make-list (syntax->datum #'n) 'args))) )] - [(_ n:expr) - #'(lambda args - (apply values - (apply append - (make-list n args))))])) - - (define (feedback-parser stx) - (syntax-parse stx - [(_ ((~datum while) tilex:clause) - ((~datum then) thenex:clause) - onex:clause) - #'(feedback-while (qi0->racket onex) - (qi0->racket tilex) - (qi0->racket thenex))] - [(_ ((~datum while) tilex:clause) - ((~datum then) thenex:clause)) - #'(λ (f . args) - (apply (qi0->racket (feedback (while tilex) (then thenex) f)) - args))] - [(_ ((~datum while) tilex:clause) onex:clause) - #'(qi0->racket (feedback (while tilex) (then _) onex))] - [(_ ((~datum while) tilex:clause)) - #'(qi0->racket (feedback (while tilex) (then _)))] - [(_ n:expr - ((~datum then) thenex:clause) - onex:clause) - #'(feedback-times (qi0->racket onex) n (qi0->racket thenex))] - [(_ n:expr - ((~datum then) thenex:clause)) - #'(λ (f . args) - (apply (qi0->racket (feedback n (then thenex) f)) args))] - [(_ n:expr onex:clause) - #'(qi0->racket (feedback n (then _) onex))] - [(_ onex:clause) - #'(λ (n . args) - (apply (qi0->racket (feedback n onex)) args))] - [_:id - #'(λ (n flo . args) - (apply (qi0->racket (feedback n flo)) - args))])) - - (define (side-effect-parser stx) - (syntax-parse stx - [(_ sidex:clause onex:clause) - #'(qi0->racket (-< (~> sidex ⏚) - onex))] - [(_ sidex:clause) - #'(qi0->racket (-< (~> sidex ⏚) - _))])) - - (define (amp-parser stx) - (syntax-parse stx - [_:id - #'map-values] - [(_ onex:clause) - #'(curry map-values (qi0->racket onex))] - [(_ onex0:clause onex:clause ...) - (report-syntax-error - 'amp - (syntax->datum #'(onex0 onex ...)) - "(>< flo)" - "amp expects a single qi0->racket specification, but it received many.")])) - - (define (pass-parser stx) - (syntax-parse stx - [_:id - #'filter-values] - [(_ onex:clause) - #'(curry filter-values (qi0->racket onex))])) - - (define (fold-left-parser stx) - (syntax-parse stx - [_:id - #'foldl-values] - [(_ fn init) - #'(qi0->racket (~> (-< (gen (qi0->racket fn) - (qi0->racket init)) - _) - >>))] - [(_ fn) - #'(qi0->racket (>> fn (gen ((qi0->racket fn)))))])) - - (define (fold-right-parser stx) - (syntax-parse stx - [_:id - #'foldr-values] - [(_ fn init) - #'(qi0->racket (~> (-< (gen (qi0->racket fn) - (qi0->racket init)) - _) - <<))] - [(_ fn) - #'(qi0->racket (<< fn (gen ((qi0->racket fn)))))])) - - (define (loop-parser stx) - (syntax-parse stx - [(_ pred:clause mapex:clause combex:clause retex:clause) - #'(letrec ([loop (qi0->racket (if pred - (~> (group 1 mapex loop) - combex) - retex))]) - loop)] - [(_ pred:clause mapex:clause combex:clause) - #'(qi0->racket (loop pred mapex combex ⏚))] - [(_ pred:clause mapex:clause) - #'(qi0->racket (loop pred mapex _ ⏚))] - [(_ mapex:clause) - #'(qi0->racket (loop #t mapex _ ⏚))])) - - (define (clos-parser stx) - (syntax-parse stx - [_:id - #:do [(define chirality (syntax-property stx 'chirality))] - (if (and chirality (eq? chirality 'right)) - #'(λ (f . args) (apply curryr f args)) - #'(λ (f . args) (apply curry f args)))] - [(_ onex:clause) - #:do [(define chirality (syntax-property stx 'chirality))] - (if (and chirality (eq? chirality 'right)) - #'(λ args - (qi0->racket (~> (-< _ (~> (gen args) △)) - onex))) - #'(λ args - (qi0->racket (~> (-< (~> (gen args) △) _) - onex))))])) - - (define (literal-parser stx) - (syntax-parse stx - [val:literal #'(qi0->racket (gen val))])) - - (define (blanket-template-form-parser stx) - (syntax-parse stx - ;; "prarg" = "pre-supplied argument" - [(natex prarg-pre ...+ (~datum __) prarg-post ...+) - #'(curry (curryr natex - prarg-post ...) - prarg-pre ...)] - [(natex prarg-pre ...+ (~datum __)) - #'(curry natex prarg-pre ...)] - [(natex (~datum __) prarg-post ...+) - #'(curryr natex prarg-post ...)] - [(natex (~datum __)) - #'natex]))) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt new file mode 100644 index 00000000..b26f4e27 --- /dev/null +++ b/qi-lib/flow/core/compiler.rkt @@ -0,0 +1,518 @@ +#lang racket/base + +(provide (for-syntax compile-flow + normalize-pass + deforest-pass)) + +(require (for-syntax racket/base + syntax/parse + racket/match + (only-in racket/list make-list) + "syntax.rkt" + "../aux-syntax.rkt" + "pass.rkt" + "debug.rkt" + "normalize.rkt" + "private/form-property.rkt") + "deforest.rkt" + "impl.rkt" + (only-in racket/list make-list) + racket/function + racket/undefined + (prefix-in fancy: fancy-app) + racket/list) + +(begin-for-syntax + + ;; note: this does not return compiled code but instead, + ;; syntax whose expansion compiles the code + (define (compile-flow stx) + (process-bindings + #`(qi0->racket + #,(optimize-flow stx)))) + + (define (deforest-pass stx) + ;; Note: deforestation happens only for threading, + ;; and the normalize pass strips the threading form + ;; if it contains only one expression, so this would not be hit. + (find-and-map/qi deforest-rewrite + stx)) + + (define-qi-expansion-step (~deforest-pass stx) + (deforest-pass stx)) + + (define (normalize-pass stx) + (attach-form-property + (find-and-map/qi (fix normalize-rewrite) + stx))) + + (define-qi-expansion-step (~normalize-pass stx) + (normalize-pass stx)) + + (define (optimize-flow stx) + (~deforest-pass + (~normalize-pass stx)))) + +;; Transformation rules for the `as` binding form: +;; +;; 1. escape to wrap outermost ~> with let and re-enter +;; +;; (~> flo ... (... (as name) ...)) +;; ... +;; ↓ +;; ... +;; (esc (let ([name (void)]) +;; (☯ original-flow))) +;; +;; 2. as → set! +;; +;; (as name) +;; ... +;; ↓ +;; ... +;; (~> (esc (λ (x) (set! name x))) ⏚) +;; +;; 3. Overall transformation: +;; +;; (~> flo ... (... (as name) ...)) +;; ... +;; ↓ +;; ... +;; (esc (let ([name (void)]) +;; (☯ (~> flo ... (... (~> (esc (λ (x) (set! name x))) ⏚) ...))))) + +(begin-for-syntax + + ;; (as name) → (~> (esc (λ (x) (set! name x))) ⏚) + ;; TODO: use a box instead of set! + (define (rewrite-all-bindings stx) + (find-and-map/qi (syntax-parser + [((~datum as) x ...) + #:with (x-val ...) (generate-temporaries (attribute x)) + #'(thread (esc (λ (x-val ...) (set! x x-val) ...)) ground)] + [_ this-syntax]) + stx)) + + (define (bound-identifiers stx) + (let ([ids null]) + (find-and-map/qi (syntax-parser + [((~datum as) x ...) + (set! ids + (append (attribute x) ids))] + [_ this-syntax]) + stx) + ids)) + + ;; wrap stx with (let ([v undefined] ...) stx) for v ∈ ids + (define (wrap-with-scopes stx ids) + (with-syntax ([(v ...) ids]) + #`(let ([v undefined] ...) #,stx))) + + (define-qi-expansion-step (process-bindings stx) + ;; TODO: use syntax-parse and match ~> specifically. + ;; Since macros are expanded "outside in," presumably + ;; it will naturally wrap the outermost ~> + (wrap-with-scopes (rewrite-all-bindings stx) + (bound-identifiers stx)))) + +(define-syntax (qi0->racket stx) + ;; this is a macro so it receives the entire expression + ;; (qi0->racket ...). We use cadr here to parse the + ;; contained expression. + (syntax-parse (cadr (syntax->list stx)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;; Core language forms ;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + [((~datum gen) ex:expr ...) + #'(λ _ (values ex ...))] + ;; pass-through (identity flow) + [(~datum _) #'values] + ;; routing + [(~or* (~datum ⏚) (~datum ground)) ; NOTE: technically not core + #'(qi0->racket (select))] + [((~or* (~datum ~>) (~datum thread)) onex:clause ...) + #`(compose . #,(reverse + (syntax->list + #'((qi0->racket onex) ...))))] + [e:relay-form (relay-parser #'e)] + [e:tee-form (tee-parser #'e)] + ;; map and filter + [e:amp-form (amp-parser #'e)] ; NOTE: technically not core + [e:pass-form (pass-parser #'e)] ; NOTE: technically not core + ;; prisms + [e:sep-form (sep-parser #'e)] + [(~or* (~datum ▽) (~datum collect)) + #'list] + ;; predicates + [(~or* (~datum NOT) (~datum !)) + #'not] + [(~datum XOR) + #'parity-xor] + [((~datum and) onex:clause ...) + #'(conjoin (qi0->racket onex) ...)] + [((~datum or) onex:clause ...) + #'(disjoin (qi0->racket onex) ...)] + [((~datum not) onex:clause) ; NOTE: technically not core + #'(negate (qi0->racket onex))] + [((~datum all) onex:clause) + #`(give (curry andmap (qi0->racket onex)))] + [((~datum any) onex:clause) + #'(give (curry ormap (qi0->racket onex)))] + + ;; selection + [e:select-form (select-parser #'e)] + [e:block-form (block-parser #'e)] + [e:group-form (group-parser #'e)] + ;; conditionals + [e:if-form (if-parser #'e)] + [e:sieve-form (sieve-parser #'e)] + [e:partition-form (partition-parser #'e)] + ;; exceptions + [e:try-form (try-parser #'e)] + ;; folds + [e:fold-left-form (fold-left-parser #'e)] + [e:fold-right-form (fold-right-parser #'e)] + ;; high-level routing + [e:fanout-form (fanout-parser #'e)] + ;; looping + [e:feedback-form (feedback-parser #'e)] + [e:loop-form (loop-parser #'e)] + [((~datum loop2) pred:clause mapex:clause combex:clause) + #'(letrec ([loop2 (qi0->racket (if pred + (~> (== (-< (esc cdr) + (~> (esc car) mapex)) _) + (group 1 _ combex) + (esc loop2)) + (select 2)))]) + loop2)] + ;; towards universality + [(~datum appleye) + #'call] + [e:clos-form (clos-parser #'e)] + ;; escape hatch for racket expressions or anything + ;; to be "passed through" + [((~datum esc) ex:expr) + #'ex] + + ;;; Miscellaneous + + ;; Partial application with syntactically pre-supplied arguments + ;; in a blanket template + ;; Note: at this point it's already been parsed/validated + ;; by the expander and we don't need to worry about checking + ;; the syntax at the compiler level + [((~datum #%blanket-template) e) + (blanket-template-form-parser this-syntax)] + + ;; Fine-grained template-based application + ;; This handles templates that indicate a specific number of template + ;; variables (i.e. expected arguments). The semantics of template-based + ;; application here is fulfilled by the fancy-app module. In order to use + ;; it, we simply use the #%app macro provided by fancy-app instead of the + ;; implicit one used for function application in racket/base. + ;; "prarg" = "pre-supplied argument" + [((~datum #%fine-template) (prarg-pre ... (~datum _) prarg-post ...)) + #'(fancy:#%app prarg-pre ... _ prarg-post ...)] + + ;; If in the course of optimization we ever end up with a fully + ;; simplified host expression, the compiler would a priori reject it as + ;; not being a core Qi expression. So we add this extra rule here + ;; to simply pass this expression through. + ;; TODO: should `#%host-expression` be formally declared as being part + ;; of the core language by including it in the syntax-spec grammar + ;; in extended/expander.rkt? + [((~datum #%host-expression) hex) + this-syntax])) + +;; The form-specific parsers, which are delegated to from +;; the qi0->racket macro: + +#| +A note on error handling: + +Some forms, in addition to handling legitimate syntax, also have +catch-all versions that exist purely to provide a helpful message +indicating a syntax error. We do this since a priori the qi0->racket macro +would ignore syntax that doesn't match any pattern. Yet, for all of +these named forms, we know that (or at least, it is prudent to assume +that) the user intended to employ that particular form of the DSL. So +instead of allowing it to fall through for interpretation as Racket +code, which would yield potentially inscrutable errors, the catch-all +forms allow us to provide appropriate error messages at the level of +the DSL. + +|# + +(begin-for-syntax + + (define (sep-parser stx) + (syntax-parse stx + [_:id + #'(qi0->racket (if (esc list?) + (#%fine-template (apply values _)) + (#%fine-template (raise-argument-error '△ + "list?" + _))))] + [(_ onex:clause) + #'(λ (v . vs) + ((qi0->racket (~> △ (>< (#%fine-template (apply (qi0->racket onex) _ vs))))) v))])) + + (define (select-parser stx) + (syntax-parse stx + [(_ n:number ...) #'(qi0->racket (-< (esc (arg n)) ...))])) + + (define (block-parser stx) + (syntax-parse stx + [(_ n:number ...) + #'(qi0->racket (~> (esc (except-args n ...)) + △))])) + + (define (group-parser stx) + (syntax-parse stx + [(_ n:expr + selection-onex:clause + remainder-onex:clause) + #'(loom-compose (qi0->racket selection-onex) + (qi0->racket remainder-onex) + n)] + [_:id + #'(λ (n selection-flo remainder-flo . vs) + (apply (qi0->racket (group n + (esc selection-flo) + (esc remainder-flo))) vs))])) + + (define (sieve-parser stx) + (syntax-parse stx + [(_ condition:clause + sonex:clause + ronex:clause) + #'(qi0->racket (-< (~> (pass condition) sonex) + (~> (pass (not condition)) ronex)))] + [_:id + ;; sieve can be a core form once bindings + ;; are introduced into the language + #'(λ (condition sonex ronex . args) + (apply (qi0->racket (-< (~> (pass (esc condition)) (esc sonex)) + (~> (pass (not (esc condition))) (esc ronex)))) + args))])) + + (define (partition-parser stx) + (syntax-parse stx + [(_:id) + #'(qi0->racket ground)] + [(_ [cond:clause body:clause]) + #'(qi0->racket (~> (pass cond) body))] + [(_ [cond:clause body:clause] ...+) + #:with c+bs #'(list (cons (qi0->racket cond) (qi0->racket body)) ...) + #'(qi0->racket (#%blanket-template (partition-values c+bs __)))])) + + (define (try-parser stx) + (syntax-parse stx + [(_ flo + [error-condition-flo error-handler-flo] + ...+) + #'(λ args + (with-handlers ([(qi0->racket error-condition-flo) + (λ (e) + ;; TODO: may be good to support reference to the + ;; error via a binding / syntax parameter + (apply (qi0->racket error-handler-flo) args))] + ...) + (apply (qi0->racket flo) args)))])) + + (define (if-parser stx) + (syntax-parse stx + [(_ consequent:clause + alternative:clause) + #'(λ (f . args) + (if (apply f args) + (apply (qi0->racket consequent) args) + (apply (qi0->racket alternative) args)))] + [(_ condition:clause + consequent:clause + alternative:clause) + #'(λ args + (if (apply (qi0->racket condition) args) + (apply (qi0->racket consequent) args) + (apply (qi0->racket alternative) args)))])) + + (define (fanout-parser stx) + (syntax-parse stx + [_:id #'repeat-values] + [(_ n:number) + ;; a slightly more efficient compile-time implementation + ;; for literally indicated N + ;; TODO: implement this as an optimization instead + #`(λ args + (apply values + (append #,@(make-list (syntax->datum #'n) #'args))) )] + [(_ n:expr) + #'(lambda args + (apply values + (apply append + (make-list n args))))])) + + (define (feedback-parser stx) + (syntax-parse stx + [(_ ((~datum while) tilex:clause) + ((~datum then) thenex:clause) + onex:clause) + #'(feedback-while (qi0->racket onex) + (qi0->racket tilex) + (qi0->racket thenex))] + [(_ ((~datum while) tilex:clause) + ((~datum then) thenex:clause)) + #'(λ (f . args) + (apply (qi0->racket (feedback (while tilex) (then thenex) (esc f))) + args))] + [(_ ((~datum while) tilex:clause) onex:clause) + #'(qi0->racket (feedback (while tilex) (then _) onex))] + [(_ ((~datum while) tilex:clause)) + #'(qi0->racket (feedback (while tilex) (then _)))] + [(_ n:expr + ((~datum then) thenex:clause) + onex:clause) + #'(lambda args + (apply (feedback-times (qi0->racket onex) n (qi0->racket thenex)) + args))] + [(_ n:expr + ((~datum then) thenex:clause)) + #'(λ (f . args) + (apply (qi0->racket (feedback n (then thenex) (esc f))) args))] + [(_ n:expr onex:clause) + #'(qi0->racket (feedback n (then _) onex))] + [(_ onex:clause) + #'(λ (n . args) + (apply (qi0->racket (feedback n onex)) args))] + [_:id + #'(λ (n flo . args) + (apply (qi0->racket (feedback n (esc flo))) + args))])) + + (define (tee-parser stx) + (syntax-parse stx + [((~or* (~datum -<) (~datum tee)) onex:clause ...) + #'(λ args + (apply values + (append (values->list + (apply (qi0->racket onex) args)) + ...)))] + [(~or* (~datum -<) (~datum tee)) + #'repeat-values])) + + (define (relay-parser stx) + (syntax-parse stx + [((~or* (~datum ==) (~datum relay)) onex:clause ...) + #'(relay (qi0->racket onex) ...)] + [(~or* (~datum ==) (~datum relay)) + ;; review this – this "map" behavior may not be natural + ;; for relay. And map-values should probably end up being + ;; used in a compiler optimization + #'map-values])) + + (define (amp-parser stx) + (syntax-parse stx + [_:id + #'(qi0->racket ==)] + [(_ onex:clause) + #'(curry map-values (qi0->racket onex))])) + + (define (pass-parser stx) + (syntax-parse stx + [_:id + #'filter-values] + [(_ onex:clause) + #'(curry filter-values (qi0->racket onex))])) + + (define (fold-left-parser stx) + (syntax-parse stx + [_:id + #'foldl-values] + [(_ fn init) + #'(qi0->racket (~> (-< (gen (qi0->racket fn) + (qi0->racket init)) + _) + >>))] + [(_ fn) + #'(qi0->racket (>> fn (gen ((qi0->racket fn)))))])) + + (define (fold-right-parser stx) + (syntax-parse stx + [_:id + #'foldr-values] + [(_ fn init) + #'(qi0->racket (~> (-< (gen (qi0->racket fn) + (qi0->racket init)) + _) + <<))] + [(_ fn) + #'(qi0->racket (<< fn (gen ((qi0->racket fn)))))])) + + (define (loop-parser stx) + (syntax-parse stx + [(_ pred:clause mapex:clause combex:clause retex:clause) + #'(letrec ([loop (qi0->racket (if pred + (~> (group 1 mapex (esc loop)) + combex) + retex))]) + loop)] + [(_ pred:clause mapex:clause combex:clause) + #'(qi0->racket (loop pred mapex combex ⏚))] + [(_ pred:clause mapex:clause) + #'(qi0->racket (loop pred mapex _ ⏚))] + [(_ mapex:clause) + #'(qi0->racket (loop (gen #t) mapex _ ⏚))] + [_:id #'(λ (predf mapf combf retf . args) + (apply (qi0->racket (loop (esc predf) + (esc mapf) + (esc combf) + (esc retf))) + args))])) + + (define (clos-parser stx) + (syntax-parse stx + [_:id + #:do [(define chirality (syntax-property stx 'chirality))] + (if (and chirality (eq? chirality 'right)) + #'(λ (f . args) (apply curryr f args)) + #'(λ (f . args) (apply curry f args)))] + [(_ onex:clause) + #:do [(define chirality (syntax-property stx 'chirality))] + (if (and chirality (eq? chirality 'right)) + #'(λ args + (qi0->racket (~> (-< _ (~> (gen args) △)) + onex))) + #'(λ args + (qi0->racket (~> (-< (~> (gen args) △) _) + onex))))])) + + (define (blanket-template-form-parser stx) + (syntax-parse stx + ;; "prarg" = "pre-supplied argument" + ;; Note: use of currying here doesn't play well with bindings + ;; because curry / curryr immediately evaluate their arguments + ;; and resolve any references to bindings at compile time. + ;; That's why we use a lambda which delays evaluation until runtime + ;; when the reference is actually resolvable. See "anaphoric references" + ;; in the compiler meeting notes, + ;; "The Artist Formerly Known as Bindingspec" + [((~datum #%blanket-template) + (natex prarg-pre ...+ (~datum __) prarg-post ...+)) + ;; "(curry (curryr ...) ...)" + #'(lambda largs + (apply + (lambda rargs + ((kw-helper natex rargs) prarg-post ...)) + prarg-pre ... + largs))] + [((~datum #%blanket-template) (natex prarg-pre ...+ (~datum __))) + ;; "curry" + #'(lambda args + (apply natex prarg-pre ... args))] + [((~datum #%blanket-template) + (natex (~datum __) prarg-post ...+)) + ;; "curryr" + #'(lambda args + ((kw-helper natex args) prarg-post ...))]))) diff --git a/qi-lib/flow/core/debug.rkt b/qi-lib/flow/core/debug.rkt new file mode 100644 index 00000000..8c3f7c65 --- /dev/null +++ b/qi-lib/flow/core/debug.rkt @@ -0,0 +1,20 @@ +#lang racket/base + +(provide define-qi-expansion-step) + +(require macro-debugger/emit) + +;; These macros emit expansion "events" that allow the macro +;; stepper to report stages in the expansion of an expression, +;; giving us visibility into this process for debugging purposes. +;; Note that this currently does not distinguish substeps +;; of a parent expansion step. +(define (qi-expansion-step name stx0 stx1) + (emit-local-step stx0 stx1 #:id name) + stx1) + +(define-syntax-rule (define-qi-expansion-step (name stx0) + body ...) + (define (name stx0) + (let ([stx1 (let () body ...)]) + (qi-expansion-step (quote-syntax name) stx0 stx1)))) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt new file mode 100644 index 00000000..b2237343 --- /dev/null +++ b/qi-lib/flow/core/deforest.rkt @@ -0,0 +1,417 @@ +#lang racket/base + +;; This module implements the stream fusion optimization to "deforest" +;; sequences of functional transformations (e.g. map, filter, fold, etc.) +;; so that they avoid constructing intermediate representations on the +;; way to producing the final result. +;; +;; See the wiki +;; https://github.com/drym-org/qi/wiki/The-Compiler#stream-fusion +;; for an overview and some details of this implementation. + +(provide (for-syntax deforest-rewrite)) + +(require (for-syntax racket/base + syntax/parse + racket/syntax-srcloc + syntax/srcloc + "../extended/util.rkt") + racket/performance-hint + racket/match + racket/list + racket/contract/base) + +;; These bindings are used for ~literal matching to introduce implicit +;; producer/consumer when none is explicitly given in the flow. +(define cstream->list #'-cstream->list) +(define list->cstream #'-list->cstream) + +;; "Composes" higher-order functions inline by directly applying them +;; to the result of each subsequent application, with the last argument +;; being passed to the penultimate application as a (single) argument. +;; This is specialized to our implementation of stream fusion in the +;; arguments it expects and how it uses them. +(define-syntax inline-compose1 + (syntax-rules () + [(_ f) f] + [(_ [op f] rest ...) (op f (inline-compose1 rest ...))])) + +(begin-for-syntax + ;; Special "curry"ing for #%fine-templates. All #%host-expressions + ;; are passed as they are and all (~datum _) are replaced by wrapper + ;; lambda arguments. + (define ((make-fine-curry argstx minargs maxargs form-stx) ctx name) + (define argstxlst (syntax->list argstx)) + (define numargs (length argstxlst)) + (cond + [(< numargs minargs) + (raise-syntax-error (syntax->datum name) + (format "too few arguments - given ~a - accepts at least ~a" + numargs minargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))] + [(> numargs maxargs) + (raise-syntax-error (syntax->datum name) + (format "too many arguments - given ~a - accepts at most ~a" + numargs maxargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))]) + (define temporaries (generate-temporaries argstxlst)) + (define-values (allargs tmpargs) + (for/fold ([all '()] + [tmps '()] + #:result (values (reverse all) + (reverse tmps))) + ([tmp (in-list temporaries)] + [arg (in-list argstxlst)]) + (syntax-parse arg + #:datum-literals (#%host-expression) + [(#%host-expression ex) + (values (cons #'ex all) + tmps)] + [(~datum _) + (values (cons tmp all) + (cons tmp tmps))]))) + (with-syntax ([(carg ...) tmpargs] + [(aarg ...) allargs]) + #'(λ (proc) + (λ (carg ...) + (proc aarg ...))))) + + ;; Special curry for #%blanket-template. Raises syntax error if + ;; there are too many arguments. If the number of arguments is + ;; exactly the maximum, wraps into lambda without any arguments. If + ;; less than maximum, curries it from both left and right. + (define ((make-blanket-curry prestx poststx maxargs form-stx) ctx name) + (define prelst (syntax->list prestx)) + (define postlst (syntax->list poststx)) + (define numargs (+ (length prelst) (length postlst))) + (with-syntax ([(pre-arg ...) prelst] + [(post-arg ...) postlst]) + (cond + [(> numargs maxargs) + (raise-syntax-error (syntax->datum name) + (format "too many arguments - given ~a - accepts at most ~a" + numargs maxargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))] + [(= numargs maxargs) + #'(λ (v) + (λ () + (v pre-arg ... post-arg ...)))] + [else + #'(λ (v) + (λ rest + (apply v pre-arg ... + (append rest + (list post-arg ...)))))]))) + + ;; Unifying producer curry makers. The ellipsis escaping allows for + ;; simple specification of pattern variable names as bound in the + ;; syntax pattern. + (define-syntax make-producer-curry + (syntax-rules () + [(_ min-args max-args + blanket? pre-arg post-arg + fine? arg + form-stx) + (cond + [(attribute blanket?) + (make-blanket-curry #'(pre-arg (... ...)) + #'(post-arg (... ...)) + max-args + #'form-stx + )] + [(attribute fine?) + (make-fine-curry #'(arg (... ...)) min-args max-args #'form-stx)] + [else + (λ (ctx name) #'(λ (v) v))])])) + + ;; Used for producing the stream from particular + ;; expressions. Implicit producer is list->cstream-next and it is + ;; not created by using this class but rather explicitly used when + ;; no syntax class producer is matched. + (define-syntax-class fusable-stream-producer + #:attributes (next prepare contract name curry) + #:datum-literals (#%host-expression #%blanket-template #%fine-template esc __) + ;; Explicit range producers. + (pattern (~and (~or (esc (#%host-expression (~datum range))) + (~and (#%fine-template + ((#%host-expression (~datum range)) + arg ...)) + fine?) + (~and (#%blanket-template + ((#%host-expression (~datum range)) + (#%host-expression pre-arg) ... + __ + (#%host-expression post-arg) ...)) + blanket?)) + form-stx) + #:attr next #'range->cstream-next + #:attr prepare #'range->cstream-prepare + #:attr contract #'(->* (real?) (real? real?) any) + #:attr name #'range + #:attr curry (make-producer-curry 1 3 + blanket? pre-arg post-arg + fine? arg + form-stx)) + + ;; The implicit stream producer from plain list. + (pattern (~literal list->cstream) + #:attr next #'list->cstream-next + #:attr prepare #'list->cstream-prepare + #:attr contract #'(-> list? any) + #:attr name #''list->cstream + #:attr curry (λ (ctx name) #'(λ (v) v)))) + + ;; Matches any stream transformer that can be in the head position + ;; of the fused sequence even when there is no explicit + ;; producer. Procedures accepting variable number of arguments like + ;; `map` cannot be in this class. + (define-syntax-class fusable-stream-transformer0 + #:attributes (f next) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) + (pattern (~or (#%blanket-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + _))) + #:attr next #'filter-cstream-next)) + + ;; All implemented stream transformers - within the stream, only + ;; single value is being passed and therefore procedures like `map` + ;; can (and should) be matched. + (define-syntax-class fusable-stream-transformer + #:attributes (f next) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) + (pattern (~or (#%blanket-template + ((#%host-expression (~datum map)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum map)) + (#%host-expression f) + _))) + #:attr next #'map-cstream-next) + + (pattern (~or (#%blanket-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + _))) + #:attr next #'filter-cstream-next)) + + ;; Terminates the fused sequence (consumes the stream) and produces + ;; an actual result value. + (define-syntax-class fusable-stream-consumer + #:attributes (end) + #:datum-literals (#%host-expression #%blanket-template _ __ #%fine-template esc) + (pattern (~or (#%blanket-template + ((#%host-expression (~datum foldr)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~datum foldr)) + (#%host-expression op) + (#%host-expression init) + _))) + #:attr end #'(foldr-cstream-next op init)) + + (pattern (~or (#%blanket-template + ((#%host-expression (~datum foldl)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~datum foldl)) + (#%host-expression op) + (#%host-expression init) + _))) + #:attr end #'(foldl-cstream-next op init)) + + (pattern (~or (esc (#%host-expression (~datum car))) + (#%fine-template + ((#%host-expression (~datum car)) + _)) + (#%blanket-template + ((#%host-expression (~datum car)) + __))) + #:attr end #'(car-cstream-next)) + + (pattern (~literal cstream->list) + #:attr end #'(cstream-next->list))) + + ;; Used only in deforest-rewrite to properly recognize the end of + ;; fusable sequence. + (define-syntax-class non-fusable + (pattern (~not (~or _:fusable-stream-transformer + _:fusable-stream-producer + _:fusable-stream-consumer)))) + + ;; Generates a syntax for the fused operation for given + ;; sequence. The syntax list must already be in the following form: + ;; (producer transformer ... consumer) + (define (generate-fused-operation ops ctx) + (syntax-parse (reverse ops) + [(c:fusable-stream-consumer + t:fusable-stream-transformer ... + p:fusable-stream-producer) + ;; A static runtime contract is placed at the beginning of the + ;; fused sequence. And runtime checks for consumers are in + ;; their respective implementation procedure. + #`(esc + (#,((attribute p.curry) ctx (attribute p.name)) + (contract p.contract + (p.prepare + (#,@#'c.end + (inline-compose1 [t.next t.f] ... + p.next) + '#,(prettify-flow-syntax ctx) + '#,(build-source-location-vector + (syntax-srcloc ctx)))) + p.name + '#,(prettify-flow-syntax ctx) + #f + '#,(build-source-location-vector + (syntax-srcloc ctx)))))])) + + ;; Performs one step of deforestation rewrite. Should be used as + ;; many times as needed - until it returns the source syntax + ;; unchanged. + (define (deforest-rewrite stx) + (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + ;; There can be zero transformers here: + t:fusable-stream-transformer ... + c:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + t1:fusable-stream-transformer0 + t:fusable-stream-transformer ... + c:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream t1 t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + ;; Must be 1 or more transformers here: + t:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fusable-stream-transformer0 + f:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream f1 f ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + ;; return the input syntax unchanged if no rules + ;; are applicable + [_ stx]))) + +(begin-encourage-inline + + ;; Producers + + (define-inline (list->cstream-next done skip yield) + (λ (state) + (cond [(null? state) (done)] + [else (yield (car state) (cdr state))]))) + + (define-inline (list->cstream-prepare next) + (case-lambda + [(lst) (next lst)] + [rest (void)])) + + (define-inline (range->cstream-next done skip yield) + (λ (state) + (match-define (list l h s) state) + (cond [(< l h) + (yield l (cons (+ l s) (cdr state)))] + [else (done)]))) + + (define-inline (range->cstream-prepare next) + (case-lambda + [(h) (next (list 0 h 1))] + [(l h) (next (list l h 1))] + [(l h s) (next (list l h s))] + [rest (void)])) + + ;; Transformers + + (define-inline (map-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (yield (f value) state))))) + + (define-inline (filter-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (if (f value) + (yield value state) + (skip state)))))) + + ;; Consumers + + (define-inline (cstream-next->list next ctx src) + (λ (state) + (let loop ([state state]) + ((next (λ () null) + (λ (state) (loop state)) + (λ (value state) + (cons value (loop state)))) + state)))) + + (define-inline (foldr-cstream-next op init next ctx src) + (λ (state) + (let loop ([state state]) + ((next (λ () init) + (λ (state) (loop state)) + (λ (value state) + (op value (loop state)))) + state)))) + + (define-inline (foldl-cstream-next op init next ctx src) + (λ (state) + (let loop ([acc init] [state state]) + ((next (λ () acc) + (λ (state) (loop acc state)) + (λ (value state) + (loop (op value acc) state))) + state)))) + + (define-inline (car-cstream-next next ctx src) + (λ (state) + (let loop ([state state]) + ((next (λ () ((contract (-> pair? any) + (λ (v) v) + 'car-cstream-next ctx #f + src) '())) + (λ (state) (loop state)) + (λ (value state) + value)) + state)))) + + ) diff --git a/qi-lib/flow/impl.rkt b/qi-lib/flow/core/impl.rkt similarity index 83% rename from qi-lib/flow/impl.rkt rename to qi-lib/flow/core/impl.rkt index 679b6464..92a0a48d 100644 --- a/qi-lib/flow/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -1,12 +1,6 @@ #lang racket/base (provide give - ->boolean - true. - false. - any? - all? - none? map-values filter-values partition-values @@ -17,18 +11,17 @@ except-args call repeat-values - power foldl-values foldr-values values->list feedback-times - feedback-while) + feedback-while + kw-helper) (require racket/match (only-in racket/function - thunk - thunk* - negate) + negate + thunk) racket/bool racket/list racket/format @@ -38,24 +31,28 @@ (define-syntax-parse-rule (values->list body:expr ...+) (call-with-values (λ () body ...) list)) +(define (kw-helper f args) + (make-keyword-procedure + (λ (kws kws-vs . pos) + (keyword-apply f kws kws-vs (append args pos))))) + ;; we use a lambda to capture the arguments at runtime ;; since they aren't available at compile time -(define (loom-compose f g [n #f]) - (let ([n (or n (procedure-arity f))]) - (λ args - (let ([num-args (length args)]) - (if (< num-args n) - (if (= 0 num-args) - (values) - (error 'group (~a "Can't select " - n - " arguments from " - args))) - (let ([sargs (take args n)] - [rargs (drop args n)]) - (apply values - (append (values->list (apply f sargs)) - (values->list (apply g rargs)))))))))) +(define (loom-compose f g n) + (λ args + (let ([num-args (length args)]) + (if (< num-args n) + (if (= 0 num-args) + (values) + (error 'group (~a "Can't select " + n + " arguments from " + args))) + (let ([sargs (take args n)] + [rargs (drop args n)]) + (apply values + (append (values->list (apply f sargs)) + (values->list (apply g rargs))))))))) (define (parity-xor . args) (and (foldl xor #f args) #t)) @@ -120,6 +117,8 @@ [(cons v vs) (append (values->list (f v)) (~map f vs))])) +;; Note: can probably get rid of implicit packing to args, and the +;; final apply values (define (map-values f . args) (apply values (~map f args))) @@ -167,11 +166,8 @@ (call-with-values (λ () (apply b args)) list))) (apply values (apply append results))) -(define (->boolean v) (and v #t)) -(define true. (thunk* #t)) -(define false. (thunk* #f)) +(define exists ormap) -(define exists ormap) (define for-all andmap) (define (zip-with op . seqs) @@ -198,21 +194,9 @@ (λ args (apply values (zip-with call fs args)))) -(define (all? . args) - (and (for/and ([v (in-list args)]) v) #t)) - -(define (any? . args) - (and (for/or ([v (in-list args)]) v) #t)) - -(define (none? . args) - (not (for/or ([v (in-list args)]) v))) - (define (repeat-values n . vs) (apply values (apply append (make-list n vs)))) -(define (power n f) - (apply compose (make-list n f))) - (define (fold-values f init vs) (let loop ([vs vs] [accs (values->list (init))]) @@ -227,7 +211,11 @@ (fold-values f init (reverse vs))) (define (feedback-times f n then-f) - (compose then-f (power n f))) + (λ args + (if (= n 0) + (apply then-f args) + (call-with-values (thunk (apply f args)) + (feedback-times f (sub1 n) then-f))))) (define (feedback-while f condition then-f) (λ args diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt new file mode 100644 index 00000000..3eab3a0a --- /dev/null +++ b/qi-lib/flow/core/normalize.rkt @@ -0,0 +1,78 @@ +#lang racket/base + +(provide normalize-rewrite) + +(require syntax/parse + (for-template racket/base)) + +;; 0. "Qi-normal form" +(define (normalize-rewrite stx) + (syntax-parse stx + #:datum-literals (#%host-expression + #%blanket-template + #%fine-template + esc + gen + thread + pass + if + amp + relay + tee + sep + collect + __) + + ;; "deforestation" for values + ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) + [(thread _0 ... (pass f) (amp g) _1 ...) + #'(thread _0 ... (amp (if f g ground)) _1 ...)] + ;; merge pass filters in sequence + [(thread _0 ... (pass f) (pass g) _1 ...) + #'(thread _0 ... (pass (and f g)) _1 ...)] + ;; collapse deterministic conditionals + [(if (gen (#%host-expression (~datum #t))) + f + g) + #'f] + [(if (gen (#%host-expression (~datum #f))) + f + g) + #'g] + ;; trivial threading form + [(thread f) + #'f] + ;; associative laws for ~> + [(thread _0 ... (thread f ...) _1 ...) ; note: greedy matching + #'(thread _0 ... f ... _1 ...)] + ;; left and right identity for ~> + [(thread _0 ... (~datum _) _1 ...) + #'(thread _0 ... _1 ...)] + ;; composition of identity flows is the identity flow + [(thread (~datum _) ...) + #'_] + ;; amp and identity + [(amp (~datum _)) + #'_] + ;; trivial tee junction + [(tee f) + #'f] + ;; merge adjacent gens in a tee junction + [(tee _0 ... (gen a ...) (gen b ...) _1 ...) + #'(tee _0 ... (gen a ... b ...) _1 ...)] + ;; dead gen elimination + [(thread _0 ... (gen a ...) (gen b ...) _1 ...) + #'(thread _0 ... (gen b ...) _1 ...)] + ;; prism identities + ;; Note: (~> ... △ ▽ ...) can't be rewritten to `values` since that's + ;; only valid if the input is in fact a list, and is an error otherwise, + ;; and we can only know this at runtime. + [(thread _0 ... collect sep _1 ...) + #'(thread _0 ... _1 ...)] + ;; collapse `values` inside a threading form + [(thread _0 ... (esc (#%host-expression (~literal values))) _1 ...) + #'(thread _0 ... _1 ...)] + [(#%blanket-template (hex __)) + #'(esc hex)] + ;; return syntax unchanged if there are no applicable normalizations + [_ stx])) diff --git a/qi-lib/flow/core/pass.rkt b/qi-lib/flow/core/pass.rkt new file mode 100644 index 00000000..aea7f7c8 --- /dev/null +++ b/qi-lib/flow/core/pass.rkt @@ -0,0 +1,70 @@ +#lang racket/base + +(provide find-and-map/qi + fix) + +(require racket/match + syntax/parse + "private/form-property.rkt") + +;; Utilities that are used in each compiler pass + +;; Walk the syntax tree in a "top down" manner, i.e. from the root down +;; to the leaves, applying a transformation to each node. +;; The transforming function is expected to either return transformed +;; syntax or false. +;; The traversal terminates at a node if either the transforming function +;; "succeeds," returning syntax different from the original, or if it +;; returns false, indicating that the node should not be explored. +;; In the latter case, the node is left unchanged. +;; Otherwise, as long as the transformation is the identity, it will continue +;; traversing subexpressions of the node. +(define (find-and-map f stx) + ;; f : syntax? -> (or/c syntax? #f) + (match stx + [(? syntax?) (let ([stx^ (f stx)]) + (if stx^ + (if (eq? stx^ stx) + ;; no transformation was applied, so + ;; keep traversing + (datum->syntax stx + (find-and-map f (syntax-e stx)) + stx + stx) + ;; transformation was applied, so we stop + stx^) + ;; false was returned, so we stop + stx))] + [(cons a d) (cons (find-and-map f a) + (find-and-map f d))] + [_ stx])) + +;; A thin wrapper around find-and-map that does not traverse subexpressions +;; that are tagged as host language (rather than Qi) expressions +(define (find-and-map/qi f stx) + ;; #%host-expression is a Racket macro defined by syntax-spec + ;; that resumes expansion of its sub-expression with an + ;; expander environment containing the original surface bindings + ;; TODO: technically should be ~literal host expression to not + ;; collide with a user-defined #%host-expression binding, but that + ;; would never be hit in practice since that would be rewritten + ;; through expansion to a use of the core language. + (find-and-map (syntax-parser [((~datum #%host-expression) e:expr) #f] + [_ (if (form-position? this-syntax) + (f this-syntax) + this-syntax)]) + stx)) + +;; Applies f repeatedly to the init-val terminating the loop if the +;; result of f is #f or the new syntax object is eq? to the previous +;; (possibly initial) one. +;; +;; Caveats: +;; * the syntax object is not inspected, only eq? is used +;; * comparison is performed only between consecutive steps (does not handle cyclic occurences) +(define ((fix f) init-val) + (let ([new-val (f init-val)]) + (if (or (not new-val) + (eq? new-val init-val)) + init-val + ((fix f) new-val)))) diff --git a/qi-lib/flow/core/private/form-property.rkt b/qi-lib/flow/core/private/form-property.rkt new file mode 100644 index 00000000..035e4eb7 --- /dev/null +++ b/qi-lib/flow/core/private/form-property.rkt @@ -0,0 +1,55 @@ +#lang racket/base + +;; In traversing Qi syntax to apply optimization rules in the compiler, +;; we only want to apply such rules to syntax that is a legitimate use of +;; a core Qi form. A naive tree traversal may in some cases yield +;; subexpressions that aren't valid Qi syntax on their own, and we need a +;; way to a avoid attempting to optimize these. The "right way" remains +;; to be defined (e.g. either we do a tree traversal that is not naive +;; and is aware of the core language grammar, or Syntax Spec provides +;; such a traversal utility inferred from the core language grammar (for +;; use by any language), or something else. But for now, Syntax Spec +;; helps us out by attaching a syntax property to each such legitimate +;; use of core language syntax, and we look for that during tree +;; traversal (i.e. in `find-and-map`), only optimizing if it is present. +;; Whenever we synthesize syntax as part of compiler transformations, we +;; need to propagate this property too, so that subsequent optimization +;; passes see it. We also need to attach this property in tests. + +(provide form-position? + attach-form-property + tag-form-syntax + get-form-property) + +(require (only-in racket/function + curry)) + +(define (form-position? v) + (and (syntax? v) + (syntax-property v 'nonterminal))) + +(define (syntax-list? v) + (and (syntax? v) (syntax->list v))) + +(define (tree-map f tree) + (cond [(list? tree) (map (curry tree-map f) + tree)] + [(syntax-list? tree) (f (datum->syntax tree + (tree-map f (syntax->list tree)) + tree + tree))] + [else (f tree)])) + +(define (attach-form-property stx) + (syntax-property stx 'nonterminal 'floe)) + +(define (get-form-property stx) + (syntax-property stx 'nonterminal)) + +;; This traverses a syntax object and indiscriminately tags every node +;; as a form. If this operation were applied to syntax in the real +;; compiler, it would of course lead to the incorrect optimizations we +;; originally added the property to correct. +;; **It is only appropriate for use in tests.** +(define (tag-form-syntax stx) + (tree-map attach-form-property stx)) diff --git a/qi-lib/flow/syntax.rkt b/qi-lib/flow/core/syntax.rkt similarity index 73% rename from qi-lib/flow/syntax.rkt rename to qi-lib/flow/core/syntax.rkt index d8edb92d..2cf8a0ca 100644 --- a/qi-lib/flow/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -4,24 +4,19 @@ select-form block-form group-form - switch-form sieve-form partition-form try-form - fanout-form feedback-form - side-effect-form amp-form - input-alias + relay-form + tee-form + fanout-form if-form pass-form fold-left-form fold-right-form loop-form - blanket-template-form - and%-form - or%-form - right-threading-form clos-form) (require syntax/parse) @@ -59,10 +54,6 @@ See comments in flow.rkt for more details. (pattern ((~datum group) arg ...))) -(define-syntax-class switch-form - (pattern - ((~datum switch) arg ...))) - (define-syntax-class sieve-form (pattern (~datum sieve)) @@ -77,18 +68,6 @@ See comments in flow.rkt for more details. (pattern ((~datum try) arg ...))) -(define-syntax-class input-alias - (pattern - (~or* (~datum 1>) - (~datum 2>) - (~datum 3>) - (~datum 4>) - (~datum 5>) - (~datum 6>) - (~datum 7>) - (~datum 8>) - (~datum 9>)))) - (define-syntax-class if-form (pattern ((~datum if) arg ...))) @@ -105,16 +84,24 @@ See comments in flow.rkt for more details. (pattern ((~datum feedback) arg ...))) -(define-syntax-class side-effect-form - (pattern - ((~or* (~datum ε) (~datum effect)) arg ...))) - (define-syntax-class amp-form (pattern (~or* (~datum ><) (~datum amp))) (pattern ((~or* (~datum ><) (~datum amp)) arg ...))) +(define-syntax-class relay-form + (pattern + (~or* (~datum ==) (~datum relay))) + (pattern + ((~or* (~datum ==) (~datum relay)) arg ...))) + +(define-syntax-class tee-form + (pattern + (~or* (~datum -<) (~datum tee))) + (pattern + ((~or* (~datum -<) (~datum tee)) arg ...))) + (define-syntax-class pass-form (pattern (~datum pass)) @@ -135,24 +122,9 @@ See comments in flow.rkt for more details. (define-syntax-class loop-form (pattern - ((~datum loop) arg ...))) - -(define-syntax-class blanket-template-form - ;; "prarg" = "pre-supplied argument" - (pattern - (natex prarg-pre ... (~datum __) prarg-post ...))) - -(define-syntax-class and%-form + (~datum loop)) (pattern - ((~datum and%) arg ...))) - -(define-syntax-class or%-form - (pattern - ((~datum or%) arg ...))) - -(define-syntax-class right-threading-form - (pattern - ((~or* (~datum ~>>) (~datum thread-right)) arg ...))) + ((~datum loop) arg ...))) (define-syntax-class clos-form (pattern diff --git a/qi-lib/flow/expander.rkt b/qi-lib/flow/expander.rkt deleted file mode 100644 index e6a2d796..00000000 --- a/qi-lib/flow/expander.rkt +++ /dev/null @@ -1,6 +0,0 @@ -#lang racket/base - -(provide expand-flow) - -(define (expand-flow stx) - stx) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt new file mode 100644 index 00000000..9ffbdd1a --- /dev/null +++ b/qi-lib/flow/extended/expander.rkt @@ -0,0 +1,229 @@ +#lang racket/base + +(provide (for-syntax qi-macro + closed-floe) + (for-space qi + (all-defined-out) + (rename-out [ground ⏚] + [thread ~>] + [relay ==] + [tee -<] + [amp ><] + [sep △] + [collect ▽]))) + +(require syntax-spec-v1 + "../space.rkt" + (for-syntax "../aux-syntax.rkt" + "syntax.rkt" + racket/base + syntax/parse + "../../private/util.rkt")) + +(syntax-spec + + ;; Declare a compile-time datatype by which qi macros may + ;; be identified. + (extension-class qi-macro + #:binding-space qi) + + (nonterminal closed-floe + #:description "a flow expression" + + f:floe + #:binding (nest-one f [])) + + (nonterminal/nesting floe (nested) + #:description "a flow expression" + #:allow-extension qi-macro + #:binding-space qi + + (as v:racket-var ...+) + #:binding {(bind v) nested} + + (thread f:floe ...) + #:binding (nest f nested) + + (tee f:floe ...) + #:binding (nest f nested) + tee + ;; Note: `#:binding nested` is the implicit binding rule here + + (relay f:floe ...) + #:binding (nest f nested) + relay + + ;; [f nested] is the implicit binding rule + ;; anything not mentioned (e.g. nested) is treated as a + ;; subexpression that's not in any scope + ;; Note: once a nonterminal is chosen, it doesn't backtrack + ;; to consider alternatives + + (gen e:racket-expr ...) + ;; Ad hoc expansion rule to allow _ to be used in application + ;; position in a template. + ;; Without it, (_ v ...) would be treated as an error since + ;; _ is an unrelated form of the core language having different + ;; semantics. The expander would assume it is a syntax error + ;; from that perspective. + (~> ((~literal _) arg ...) #'(#%fine-template (_ arg ...))) + _ + ground + amp + (amp f:closed-floe) + (~>/form (amp f0:clause f:clause ...) + ;; potentially pull out as a phase 1 function + ;; just a stopgap until better error messages + (report-syntax-error this-syntax + "(>< flo)" + "amp expects a single flow specification, but it received many.")) + pass + (pass f:closed-floe) + sep + (sep f:closed-floe) + collect + NOT + XOR + (and f:closed-floe ...) + (or f:closed-floe ...) + (not f:closed-floe) + (all f:closed-floe) + (any f:closed-floe) + (select n:number ...) + (~>/form (select arg ...) + (report-syntax-error this-syntax + "(select ...)")) + (block n:number ...) + (~>/form (block arg ...) + (report-syntax-error this-syntax + "(block ...)")) + (fanout n:number) + (fanout n:racket-expr) + fanout + (group n:racket-expr e1:closed-floe e2:closed-floe) + group + (~>/form (group arg ...) + (report-syntax-error this-syntax + "(group )")) + (if consequent:closed-floe + alternative:closed-floe) + (if condition:floe + consequent:closed-floe + alternative:closed-floe) + #:binding (nest-one condition [consequent alternative]) + (sieve condition:closed-floe + sonex:closed-floe + ronex:closed-floe) + sieve + (~>/form (sieve arg ...) + (report-syntax-error this-syntax + "(sieve )")) + (partition) + (partition [cond:closed-floe body:closed-floe] ...+) + (try flo:closed-floe + [error-condition-flo:closed-floe error-handler-flo:closed-floe] + ...+) + (~>/form (try arg ...) + (report-syntax-error this-syntax + "(try [error-predicate-flo error-handler-flo] ...)")) + >> + (>> fn:closed-floe init:closed-floe) + (>> fn:closed-floe) + << + (<< fn:closed-floe init:closed-floe) + (<< fn:closed-floe) + (feedback ((~datum while) tilex:closed-floe) + ((~datum then) thenex:closed-floe) + onex:closed-floe) + (feedback ((~datum while) tilex:closed-floe) + ((~datum then) thenex:closed-floe)) + (feedback ((~datum while) tilex:closed-floe) onex:closed-floe) + (feedback ((~datum while) tilex:closed-floe)) + (feedback n:racket-expr + ((~datum then) thenex:closed-floe) + onex:closed-floe) + (feedback n:racket-expr + ((~datum then) thenex:closed-floe)) + (feedback n:racket-expr onex:closed-floe) + (feedback onex:closed-floe) + feedback + (loop pred:closed-floe mapex:closed-floe combex:closed-floe retex:closed-floe) + (loop pred:closed-floe mapex:closed-floe combex:closed-floe) + (loop pred:closed-floe mapex:closed-floe) + (loop mapex:closed-floe) + loop + (loop2 pred:closed-floe mapex:closed-floe combex:closed-floe) + appleye + (~> (~literal apply) #'appleye) + clos + (clos onex:closed-floe) + (esc ex:racket-expr) + + ;; backwards compat macro extensibility via Racket macros + (~> ((~var ext-form (starts-with "qi:")) expr ...) + #'(esc (ext-form expr ...))) + ;; a literal is interpreted as a flow generating it + (~> val:literal + #'(gen val)) + ;; Certain rules of the language aren't determined by the "head" + ;; position, so naively, these can't be core forms. In order to + ;; treat them as core forms, we tag them at the expander level + ;; by wrapping them with #%-prefixed forms, similar to Racket's + ;; approach to a similiar case - "interposition points." These + ;; new forms can then be treated as core forms in the compiler. + ;; + ;; Be careful with these tagging rules, though -- if they are too + ;; lax in their match criteria they may produce infinite code + ;; unless their output is matched prior to reaching the tagging rule. + ;; So core forms expected to be produced by these tagging rules + ;; should generally occur before the tagging rule + (#%blanket-template (arg:arg-stx ...)) + (~> f:blanket-template-form + #'(#%blanket-template f)) + + (#%fine-template (arg:arg-stx ...)) + (~> f:fine-template-form + #'(#%fine-template f)) + + ;; When there is a partial application where a template hasn't + ;; explicitly been indicated, we rewrite it to an equivalent use + ;; of a blanket template. + ;; We use a blanket rather than fine template since in such cases, + ;; we cannot always infer the appropriate arity for a template + ;; (e.g. it may change under composition within the form), while a + ;; blanket template will accept any number of arguments + (~> f:partial-application-form + #:do [(define chirality (syntax-property this-syntax 'chirality))] + (if (and chirality (eq? chirality 'right)) + (datum->syntax this-syntax + (append (syntax->list this-syntax) + (list '__))) + (datum->syntax this-syntax + (let ([stx-list (syntax->list this-syntax)]) + (cons (car stx-list) + (cons '__ (cdr stx-list))))))) + ;; literally indicated function identifier + ;; + ;; functions defined in the Qi binding space take precedence over + ;; Racket definitions here, for cases of "library functions" like + ;; `count` that we don't include in the core language but which + ;; we'd like to treat as part of the language rather than as + ;; functions which could be shadowed. + (~> f:id + #:with spaced-f (introduce-qi-syntax #'f) + #'(esc spaced-f))) + + (nonterminal arg-stx + (~datum _) + (~datum __) + k:keyword + + e:racket-expr)) + + +(module+ invoke + (provide (for-syntax expand-flow)) + + (begin-for-syntax + (define (expand-flow stx) + ((nonterminal-expander closed-floe) stx)))) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt new file mode 100644 index 00000000..a1080b8f --- /dev/null +++ b/qi-lib/flow/extended/forms.rkt @@ -0,0 +1,192 @@ +#lang racket/base + +(provide (for-space qi + (all-defined-out) + ;; defining and using a `define-qi-alias` form + ;; would be a more direct way to do this + (rename-out [thread-right ~>>] + [crossover X] + [relay* ==*] + [effect ε]))) + +(require (for-syntax racket/base + "syntax.rkt" + "../aux-syntax.rkt") + syntax/parse/define + "expander.rkt" + "../../macro.rkt" + "../space.rkt" + "impl.rkt") + +;;; Predicates + +(define-for-qi all? ~all?) + +(define-for-qi AND ~all?) + +(define-for-qi OR ~any?) + +(define-for-qi any? ~any?) + +(define-for-qi none? ~none?) + +(define-qi-syntax-rule (one-of? v:expr ...) + (~> (member (list v ...)) ->boolean)) + +(define-qi-syntax-rule (none onex:clause) + (not (any onex))) + +(define-qi-syntax-parser NOR + [_:id #'(~> OR NOT)]) + +(define-qi-syntax-parser NAND + [_:id #'(~> AND NOT)]) + +(define-qi-syntax-parser XNOR + [_:id #'(~> XOR NOT)]) + +(define-qi-syntax-rule (and% onex:conjux-clause ...) + (~> (== onex.parsed ...) + all?)) + +(define-qi-syntax-rule (or% onex:disjux-clause ...) + (~> (== onex.parsed ...) + any?)) + +;;; Routing + +;; Right-threading is just normal threading but with a syntax +;; property attached to the components indicating the chirality +(define-qi-syntax-rule (thread-right onex:right-threading-clause ...) + (~> onex.chiral ...)) + +(define-qi-syntax-parser crossover + [_:id #'(~> ▽ reverse △)]) + +(define-qi-syntax-parser relay* + [(_ onex:clause ... rest-onex:clause) + #:with len #`#,(length (syntax->list #'(onex ...))) + #'(group len (== onex ...) rest-onex)]) + +(define-qi-syntax-rule (bundle (n:number ...) + selection-onex:clause + remainder-onex:clause) + (-< (~> (select n ...) selection-onex) + (~> (block n ...) remainder-onex))) + +;;; Conditionals + +(define-qi-syntax-rule (when condition:clause + consequent:clause) + (if condition consequent ⏚)) + +(define-qi-syntax-rule (unless condition:clause + alternative:clause) + (if condition ⏚ alternative)) + +(define-qi-syntax-parser switch + [(_) #'_] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause)) + #'consequent-gate] + [(_ [(~datum else) alternative:clause]) + #'alternative] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause) + [(~datum else) alternative:clause]) + #'(~> consequent-gate alternative)] + [(_ [condition0:clause ((~datum =>) consequent0:clause ...)] + [condition:clause consequent:clause] + ...) + ;; we split the flow ahead of time to avoid evaluating + ;; the condition more than once + #'(~> (-< condition0 _) + (if 1> + (~> consequent0 ...) + (group 1 ⏚ + (switch [condition consequent] + ...))))] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause) + [condition0:clause ((~datum =>) consequent0:clause ...)] + [condition:clause consequent:clause] + ...) + ;; both divert as well as => clauses. Here, the divert clause + ;; operates on the original inputs, not including the result + ;; of the condition flow. + ;; as before, we split the flow ahead of time to avoid evaluating + ;; the condition more than once + #'(~> (-< (~> condition-gate condition0) _) + (if 1> + (~> (group 1 _ consequent-gate) + consequent0 ...) + (group 1 ⏚ + (switch (divert condition-gate consequent-gate) + [condition consequent] + ...))))] + [(_ [condition0:clause consequent0:clause] + [condition:clause consequent:clause] + ...) + #'(if condition0 + consequent0 + (switch [condition consequent] + ...))] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause) + [condition0:clause consequent0:clause] + [condition:clause consequent:clause] + ...) + #'(if (~> condition-gate condition0) + (~> consequent-gate consequent0) + (switch (divert condition-gate consequent-gate) + [condition consequent] + ...))]) + +(define-qi-syntax-rule (gate onex:clause) + (if onex _ ⏚)) + +;;; Common utilities + +(define-for-qi count ~count) + +(define-for-qi live? ~live?) + +(define-qi-syntax-rule (rectify v:expr ...) + (if live? _ (gen v ...))) + +;;; High level circuit elements + +;; aliases for inputs +(define-qi-syntax-parser 1> + [_:id #'(select 1)]) +(define-qi-syntax-parser 2> + [_:id #'(select 2)]) +(define-qi-syntax-parser 3> + [_:id #'(select 3)]) +(define-qi-syntax-parser 4> + [_:id #'(select 4)]) +(define-qi-syntax-parser 5> + [_:id #'(select 5)]) +(define-qi-syntax-parser 6> + [_:id #'(select 6)]) +(define-qi-syntax-parser 7> + [_:id #'(select 7)]) +(define-qi-syntax-parser 8> + [_:id #'(select 8)]) +(define-qi-syntax-parser 9> + [_:id #'(select 9)]) + +(define-qi-syntax-parser inverter + [_:id #'(>< NOT)]) + +(define-qi-syntax-parser effect + [(_ sidex:clause onex:clause) + #'(-< (~> sidex ⏚) + onex)] + [(_ sidex:clause) + #'(-< (~> sidex ⏚) + _)]) diff --git a/qi-lib/flow/extended/impl.rkt b/qi-lib/flow/extended/impl.rkt new file mode 100644 index 00000000..8ac1328e --- /dev/null +++ b/qi-lib/flow/extended/impl.rkt @@ -0,0 +1,41 @@ +#lang racket/base + +(require (only-in racket/function + const)) + +(provide ->boolean + true. + false. + ~all? + ~any? + ~none? + ~count + ~live?) + +(define (->boolean v) (and v #t)) + +(define true. + (procedure-rename (const #t) + 'true.)) + +(define false. + (procedure-rename (const #f) + 'false.)) + +(define (~all? . args) + (for/and ([v (in-list args)]) v)) + +(define (~any?-helper args) + (for/or ([v (in-list args)]) v)) + +(define (~any? . args) + (~any?-helper args)) + +(define (~none? . args) + (not (~any?-helper args))) + +(define (~count . args) + (length args)) + +(define (~live? . args) + (not (null? args))) diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt new file mode 100644 index 00000000..1691380e --- /dev/null +++ b/qi-lib/flow/extended/syntax.rkt @@ -0,0 +1,68 @@ +#lang racket/base + +(provide conjux-clause + disjux-clause + right-threading-clause + blanket-template-form + fine-template-form + partial-application-form + any-stx + ;; only provided for use in unit tests + make-right-chiral) + +(require syntax/parse + "../aux-syntax.rkt" + (for-template "impl.rkt")) + +(define-syntax-class conjux-clause ; "juxtaposed" conjoin + #:attributes (parsed) + (pattern + (~datum _) + #:with parsed #'true.) + (pattern + onex:clause + #:with parsed #'onex)) + +(define-syntax-class disjux-clause ; "juxtaposed" disjoin + #:attributes (parsed) + (pattern + (~datum _) + #:with parsed #'false.) + (pattern + onex:clause + #:with parsed #'onex)) + +(define-syntax-class pre-supplied-argument + (pattern + (~not + (~or (~datum _) + (~datum __))))) + +(define (make-right-chiral stx) + (syntax-property stx 'chirality 'right)) + +(define-syntax-class right-threading-clause + (pattern + onex:clause + #:with chiral (make-right-chiral #'onex))) + +;; Note these are used in the expander instead of in the compiler. +;; That's why they don't need the tag (i.e. they don't look for +;; #%blanket-template, #%fine-template, or #%partial-application) +(define-syntax-class blanket-template-form + ;; "prarg" = "pre-supplied argument" + (pattern + (natex prarg-pre ... (~datum __) prarg-post ...))) + +(define-syntax-class fine-template-form + ;; "prarg" = "pre-supplied argument" + (pattern + (prarg-pre ... (~datum _) prarg-post ...))) + +(define-syntax-class partial-application-form + ;; "prarg" = "pre-supplied argument" + (pattern + (natex prarg:pre-supplied-argument ...+))) + +(define-syntax-class any-stx + (pattern _)) diff --git a/qi-lib/flow/extended/util.rkt b/qi-lib/flow/extended/util.rkt new file mode 100644 index 00000000..4a467f20 --- /dev/null +++ b/qi-lib/flow/extended/util.rkt @@ -0,0 +1,121 @@ +#lang racket/base + +(provide prettify-flow-syntax) + +(require syntax/parse) + +;; Partially reconstructs original flow expressions. The chirality +;; is lost and the form is already normalized at this point though! +(define (prettify-flow-syntax stx) + (syntax-parse stx + #:datum-literals (#%host-expression + esc + #%blanket-template + #%fine-template + thread + amp + tee + relay + gen + pass + sep + and + or + not + all + any + fanout + group + if + sieve + partition + try + >> + << + feedback + loop + loop2 + clos) + [(thread + expr ...) + #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [((~or #%blanket-template #%fine-template) + (expr ...)) + (map prettify-flow-syntax (syntax->list #'(expr ...)))] + [(#%host-expression expr) #'expr] + [(amp + expr ...) + #`(>< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(tee + expr ...) + #`(-< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(relay + expr ...) + #`(== #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(gen + expr ...) + #`(gen #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(pass + expr ...) + #`(pass #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(sep + expr ...) + #`(sep #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(and + expr ...) + #`(and #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(or + expr ...) + #`(or #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(not + expr ...) + #`(not #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(all + expr ...) + #`(all #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(any + expr ...) + #`(any #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(fanout + expr ...) + #`(fanout #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(group + expr ...) + #`(group #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(if + expr ...) + #`(if #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(sieve + expr ...) + #`(sieve #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(partition + [e1 e2] ...) + #:with (e1-prettified ...) (map prettify-flow-syntax (attribute e1)) + #:with (e2-prettified ...) (map prettify-flow-syntax (attribute e2)) + #'(partition [e1-prettified e2-prettified] ...)] + [(try expr + [e1 e2] ...) + #:with expr-prettified (prettify-flow-syntax #'expr) + #:with (e1-prettified ...) (map prettify-flow-syntax (attribute e1)) + #:with (e2-prettified ...) (map prettify-flow-syntax (attribute e2)) + #'(try expr-prettified [e1-prettified e2-prettified] ...)] + [(>> + expr ...) + #`(>> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(<< + expr ...) + #`(<< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(feedback + expr ...) + #`(feedback #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(loop + expr ...) + #`(loop #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(loop2 + expr ...) + #`(loop2 #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(clos + expr ...) + #`(clos #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(esc expr) (prettify-flow-syntax #'expr)] + [expr #'expr])) diff --git a/qi-lib/flow/space.rkt b/qi-lib/flow/space.rkt new file mode 100644 index 00000000..b2b3ca9a --- /dev/null +++ b/qi-lib/flow/space.rkt @@ -0,0 +1,55 @@ +#lang racket/base + +(provide define-for-qi + define-qi-syntax + define-qi-alias + (for-syntax + introduce-qi-syntax)) + +(require syntax/parse/define + (for-syntax racket/base + syntax/parse/lib/function-header)) + +(begin-for-syntax + (define introduce-qi-syntax + (make-interned-syntax-introducer 'qi))) + +;; Define variables in the qi binding space. +;; This allows us to define functions in the qi space which, when used in +;; qi contexts, would not be shadowed by bindings at the use site. This +;; gives us some of the benefits of core linguistic forms while also not +;; actually inflating the size of the core language nor incurring the +;; performance penalty it might if it were implemented as a macro +;; compiling to the core language. +;; See "A loophole in Qi space": +;; https://github.com/drym-org/qi/wiki/Qi-Compiler-Sync-Jan-26-2023 +(define-syntax-parser define-for-qi + [(_ name:id expr:expr) + #:with spaced-name (introduce-qi-syntax #'name) + #'(define spaced-name expr)] + [(_ (name:id . args:formals) + expr:expr ...) + #'(define-for-qi name + (lambda args + expr ...))]) + +(define-syntax-parser define-qi-syntax + [(_ name transformer) + #:with spaced-name (introduce-qi-syntax #'name) + #'(define-syntax spaced-name transformer)]) + +(define-syntax-parser define-qi-alias + [(_ alias:id name:id) + #:with spaced-name (introduce-qi-syntax #'name) + #'(define-qi-syntax alias (make-rename-transformer #'spaced-name))]) + +;; reference bindings in qi space +;; this is in a submodule since it's only used in testing +;; and we don't provide it publicly +(module+ refer + (provide reference-qi) + + (define-syntax-parser reference-qi + [(_ name) + #:with spaced-name (introduce-qi-syntax #'name) + #'spaced-name])) diff --git a/qi-lib/info.rkt b/qi-lib/info.rkt index aec2a73a..a8b349bd 100644 --- a/qi-lib/info.rkt +++ b/qi-lib/info.rkt @@ -3,7 +3,9 @@ (define version "3.0") (define collection "qi") (define deps '("base" - ("fancy-app" #:version "1.1"))) + ("fancy-app" #:version "1.1") + "syntax-spec-v1" + "macro-debugger")) (define build-deps '()) (define clean '("compiled" "private/compiled")) (define pkg-authors '(countvajhula)) diff --git a/qi-lib/macro.rkt b/qi-lib/macro.rkt index df1a7003..7a0e8404 100644 --- a/qi-lib/macro.rkt +++ b/qi-lib/macro.rkt @@ -4,21 +4,20 @@ define-qi-syntax-rule define-qi-syntax-parser define-qi-foreign-syntaxes - (for-syntax qi-macro? - qi-macro-transformer - qi-macro)) + (for-syntax qi-macro)) (require (for-syntax racket/base - syntax/parse racket/format racket/match racket/list) - racket/format + (only-in "flow/extended/expander.rkt" + qi-macro + esc) + qi/flow/space syntax/parse/define syntax/parse) (begin-for-syntax - (struct qi-macro [transformer]) (define (foreign-template-arg-indices tmpl) ;; return a list of indices corresponding to @@ -88,16 +87,10 @@ #'(esc (lambda (v) (original-macro v form ...))))] [name:id #'(esc (lambda (v) (original-macro v)))])))) -(define-syntax define-qi-syntax - (syntax-parser - [(_ name transformer) - #`(define-syntax #,((make-interned-syntax-introducer 'qi) #'name) - transformer)])) - (define-syntax define-qi-syntax-rule (syntax-parser [(_ (name . pat) template) - #`(define-syntax #,((make-interned-syntax-introducer 'qi) #'name) + #'(define-qi-syntax name (qi-macro (syntax-parser [(_ . pat) #'template])))])) @@ -105,7 +98,7 @@ (define-syntax define-qi-syntax-parser (syntax-parser [(_ name clause ...) - #`(define-syntax #,((make-interned-syntax-introducer 'qi) #'name) + #'(define-qi-syntax name (qi-macro (syntax-parser clause ...)))])) @@ -113,8 +106,6 @@ (define-syntax define-qi-foreign-syntaxes (syntax-parser [(_ form-name ...) - #:with (spaced-form-name ...) (map (make-interned-syntax-introducer 'qi) - (attribute form-name)) #'(begin - (define-syntax spaced-form-name (make-qi-foreign-syntax-transformer #'form-name)) + (define-qi-syntax form-name (make-qi-foreign-syntax-transformer #'form-name)) ...)])) diff --git a/qi-lib/main.rkt b/qi-lib/main.rkt index 4e38131d..b81c616e 100644 --- a/qi-lib/main.rkt +++ b/qi-lib/main.rkt @@ -8,9 +8,7 @@ qi/threading)) (require qi/flow - (except-in qi/macro - qi-macro-transformer - qi-macro?) + qi/macro qi/on qi/switch qi/threading) diff --git a/qi-lib/private/util.rkt b/qi-lib/private/util.rkt index 1dd34c61..4a6c329a 100644 --- a/qi-lib/private/util.rkt +++ b/qi-lib/private/util.rkt @@ -6,21 +6,25 @@ (require racket/string racket/format + racket/match syntax/parse/define (for-syntax racket/base syntax/parse/lib/function-header)) -(define (report-syntax-error name args usage . msgs) - (raise-syntax-error name - (~a "Syntax error in " - (list* name args) - "\n" - "Usage:\n" - " " usage - (if (null? msgs) - "" - (string-append "\n" - (string-join msgs "\n")))))) +(define (report-syntax-error stx usage . msgs) + (match (syntax->datum stx) + [(cons name args) + (raise-syntax-error name + (~a "Syntax error in " + (list* name args) + "\n" + "Usage:\n" + " " usage + (if (null? msgs) + "" + (string-append "\n" + (string-join msgs "\n")))) + stx)])) (define-syntax-parse-rule (define-alias alias:id name:id) (define-syntax alias (make-rename-transformer #'name))) diff --git a/qi-lib/switch.rkt b/qi-lib/switch.rkt index a6b8ce7d..a5c3dbf2 100644 --- a/qi-lib/switch.rkt +++ b/qi-lib/switch.rkt @@ -1,6 +1,10 @@ #lang racket/base -(provide switch +;; This name juggling is necessary since the Racket macros would +;; otherwise collide with the Qi forms with the same name in the qi +;; binding space, since Qi forms are now exported literals and not simply +;; matched as datum patterns as they were formerly. +(provide (rename-out [%switch switch]) switch-lambda switch-λ λ01 @@ -16,7 +20,7 @@ define-alias params-parser)) -(define-syntax-parser switch +(define-syntax-parser %switch [(_ args:subject clause ...) #'(on args @@ -30,7 +34,7 @@ [(_ args:formals expr:expr ...) #:with ags (params-parser #'args) #'(lambda args - (switch ags + (%switch ags expr ...))]) (define-alias λ01 switch-lambda) @@ -44,4 +48,4 @@ expr ...))] [(_ name:id expr:expr ...) #'(define name - (☯ (switch expr ...)))]) + (flow (switch expr ...)))]) diff --git a/qi-lib/threading.rkt b/qi-lib/threading.rkt index 7c20effe..42ac361b 100644 --- a/qi-lib/threading.rkt +++ b/qi-lib/threading.rkt @@ -1,35 +1,38 @@ #lang racket/base -(provide ~> - ~>>) +;; This name juggling is necessary since the Racket macros would +;; otherwise collide with the Qi forms with the same name in the qi +;; binding space, since Qi forms are now exported literals and not simply +;; matched as datum patterns as they were formerly. +(provide (rename-out [%~> ~>] + [%~>> ~>>])) (require syntax/parse/define (for-syntax racket/base (only-in "private/util.rkt" report-syntax-error) "flow/aux-syntax.rkt") + "flow.rkt" "on.rkt") -(define-syntax-parser ~> - [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) +(define-syntax-parser %~> + [(_ (arg0:expr arg:expr ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error - (report-syntax-error '~> - (syntax->datum #'((arg0 arg ...) sep clause ...)) - "(~> (arg ...) flo ...)" - "Attempted to separate multiple values." - "Note that the inputs to ~> must be wrapped in parentheses.")] + (report-syntax-error this-syntax + "(~> (arg ...) flo ...)" + "Attempted to separate multiple values." + "Note that the inputs to ~> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) #'(on ags (~> clause ...))]) -(define-syntax-parser ~>> - [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) +(define-syntax-parser %~>> + [(_ (arg0:expr arg:expr ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error - (report-syntax-error '~>> - (syntax->datum #'((arg0 arg ...) sep clause ...)) - "(~>> (arg ...) flo ...)" - "Attempted to separate multiple values." - "Note that the inputs to ~>> must be wrapped in parentheses.")] + (report-syntax-error this-syntax + "(~>> (arg ...) flo ...)" + "Attempted to separate multiple values." + "Note that the inputs to ~>> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) #'(on ags (~>> clause ...))]) diff --git a/qi-sdk/info.rkt b/qi-sdk/info.rkt index 8ee90a5e..ea3ccec2 100644 --- a/qi-sdk/info.rkt +++ b/qi-sdk/info.rkt @@ -9,6 +9,8 @@ "math-lib" "collections-lib" "relation-lib" + "csv-writing" + "require-latency" "cover" "cover-coveralls")) (define build-deps '()) diff --git a/qi-sdk/profile/competitive.rkt b/qi-sdk/profile/competitive.rkt deleted file mode 100644 index 3fde6766..00000000 --- a/qi-sdk/profile/competitive.rkt +++ /dev/null @@ -1,76 +0,0 @@ -#lang racket/base - -(require (only-in data/collection - cycle - take - in) - (only-in racket/list - range) - (only-in racket/function - curryr) - (prefix-in q: "qi.rkt") - (prefix-in b: "builtin.rkt")) - -(require "util.rkt") - -(displayln "\nRunning flat benchmarks...") - -(run-competitive-benchmark "Conditionals" - check-value - cond-fn - 300000) - -(run-competitive-benchmark "Composition" - check-value - compose-fn - 300000) - -(run-competitive-benchmark "Root Mean Square" - check-list - root-mean-square - 500000) - -(run-competitive-benchmark "Filter-map" - check-list - filter-map-fn - 500000) - -(run-competitive-benchmark "Filter-map values" - check-values - filter-map-values - 500000) - -(run-competitive-benchmark "Double list" - check-list - double-list - 500000) - -(run-competitive-benchmark "Double values" - check-values - double-values - 500000) - -(displayln "\nRunning Recursive benchmarks...") - -(run-competitive-benchmark "Factorial" - check-value - fact - 100000) - -(run-competitive-benchmark "Pingala" - check-value - ping - 10000) - -(define check-value-primes (curryr check-value #(100 200 300))) - -(run-competitive-benchmark "Eratosthenes" - check-value-primes - eratos - 100) - -;; See https://en.wikipedia.org/wiki/Collatz_conjecture -(run-competitive-benchmark "Collatz" - check-value - collatz - 10000) diff --git a/qi-sdk/profile/loading/loadlib.rkt b/qi-sdk/profile/loading/loadlib.rkt new file mode 100755 index 00000000..b0dae806 --- /dev/null +++ b/qi-sdk/profile/loading/loadlib.rkt @@ -0,0 +1,16 @@ +#!/usr/bin/env racket +#lang racket/base + +(provide profile-load) + +(require pkg/require-latency + racket/format) + +(define (profile-load module-name) + (let ([name (~a "(require " module-name ")")] + [ms (cdr (time-module-ms module-name))]) + (displayln (~a name ": " ms " ms") + (current-error-port)) + (hash 'name name + 'unit "ms" + 'value ms))) diff --git a/qi-sdk/profile/loading/report.rkt b/qi-sdk/profile/loading/report.rkt new file mode 100755 index 00000000..e91d64de --- /dev/null +++ b/qi-sdk/profile/loading/report.rkt @@ -0,0 +1,41 @@ +#!/usr/bin/env racket +#lang cli + +(require racket/match + racket/format + relation + qi + (only-in "../util.rkt" + only-if + for/call + write-csv + format-output) + "../regression.rkt" + "loadlib.rkt") + +(help + (usage + (~a "Measure module load time, i.e. the time taken by (require qi)."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(program (main) + (displayln "\nMeasuring module load time..." (current-error-port)) + + (let ([output (profile-load "qi")]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (format-output (compute-regression before after) + (output-format))) + (format-output output (output-format))))) + +(run main) diff --git a/qi-sdk/profile/loadlib.rkt b/qi-sdk/profile/loadlib.rkt deleted file mode 100755 index 4ebdaed6..00000000 --- a/qi-sdk/profile/loadlib.rkt +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/env racket -#lang cli - -(provide time-racket - time-module-ms) - -(require racket/port - racket/format) - -#| -This works by: -1. Running `racket -l ` and `racket -l racket/base` independently -2. Subtracting the latter from the former. -3. Printing that result in milliseconds. - -where is the argument you specified at the command line, -e.g. ./loadlib.rkt racket/list - -The idea is to subtract out the contribution from racket/base, so that -what remains is just the time contributed by requiring the specified module. -|# - -(define (time-racket [module-name "racket/base"]) - (define-values (sp out in err) - (subprocess #f #f #f (find-executable-path "time") "-p" (find-executable-path "racket") "-l" module-name)) - (define result (port->string err)) - (define seconds (string->number - (car - (regexp-match #px"[\\d|\\.]+" - (car - (regexp-match #rx"(?m:^real.*)" - result)))))) - (close-input-port out) - (close-output-port in) - (close-input-port err) - (subprocess-wait sp) - seconds) - -(define (time-module-ms module-name) - (* 1000 - (- (time-racket module-name) - (time-racket)))) - -(program (time-require module-name) - (displayln (~a (time-module-ms module-name) " ms"))) - -(module+ main - (run time-require)) diff --git a/qi-sdk/profile/forms-base.rkt b/qi-sdk/profile/local/base.rkt similarity index 69% rename from qi-sdk/profile/forms-base.rkt rename to qi-sdk/profile/local/base.rkt index 707bc19a..7431b112 100644 --- a/qi-sdk/profile/forms-base.rkt +++ b/qi-sdk/profile/local/base.rkt @@ -2,11 +2,9 @@ (provide (all-from-out racket/base) (all-from-out qi) - (all-from-out "util.rkt") + (all-from-out "../util.rkt") sqr) (require qi - "util.rkt" + "../util.rkt" (only-in math sqr)) - - diff --git a/qi-sdk/profile/forms.rkt b/qi-sdk/profile/local/benchmarks.rkt old mode 100644 new mode 100755 similarity index 76% rename from qi-sdk/profile/forms.rkt rename to qi-sdk/profile/local/benchmarks.rkt index 5cd5a383..75c3d73b --- a/qi-sdk/profile/forms.rkt +++ b/qi-sdk/profile/local/benchmarks.rkt @@ -1,3 +1,4 @@ +#!/usr/bin/env racket #lang racket/base #| @@ -10,92 +11,97 @@ utility macros `run-benchmark` or `run-summary-benchmark`, and provides it one of the helper functions `check-value` (to invoke the form with a single value each time during benchmarking) or `check-values` (to invoke the form with multiple values each time -during benchmarking). +during benchmarking). Note that at the moment, as a hack for +convenience, `run-benchmark` expects a function with the name of the +form being benchmarked _prefixed with tilde_. This is to avoid name +collisions between this function and the Qi form with the same +name. Basically, just follow one of the numerous examples in this +module to see what this is referring to. 2. Require the submodule in the `main` submodule with an appropriate prefix (see other examples) 3. Add the required `run` function to the `env` hash in the main -submodule. This will ensure that it gets picked up when the benchmarks +submodule. This will ensure that it gets picked up when the benchmarks for the forms are run. |# -(module one-of? "forms-base.rkt" +(module one-of? "base.rkt" (provide run) - (define (one-of? v) + (define (~one-of? v) ((☯ (one-of? 3 5 7)) v)) (define (run) - (run-benchmark one-of? + (run-benchmark ~one-of? check-value 100000))) -(module and "forms-base.rkt" +(module and "base.rkt" (provide run) - (define (and v) + (define (~and v) ((☯ (and positive? integer?)) v)) (define (run) - (run-benchmark and + (run-benchmark ~and check-value 200000))) -(module or "forms-base.rkt" +(module or "base.rkt" (provide run) - (define (or v) + (define (~or v) ((☯ (or positive? integer?)) v)) (define (run) - (run-benchmark or + (run-benchmark ~or check-value 200000))) -(module not "forms-base.rkt" +(module not "base.rkt" (provide run) - (define (not v) + (define (~not v) ((☯ (not integer?)) v)) (define (run) - (run-benchmark not + (run-benchmark ~not check-value 200000))) -(module and% "forms-base.rkt" +(module and% "base.rkt" (provide run) - (define (and% a b) + (define (~and% a b) ((☯ (and% positive? integer?)) a b)) (define (run) - (run-benchmark and% + (run-benchmark ~and% check-two-values 200000))) -(module or% "forms-base.rkt" +(module or% "base.rkt" (provide run) - (define (or% a b) + (define (~or% a b) ((☯ (or% positive? integer?)) a b)) (define (run) - (run-benchmark or% + (run-benchmark ~or% check-two-values 200000))) -(module group "forms-base.rkt" +(module group "base.rkt" (provide run) - (define (group . vs) + (define (~group . vs) (apply (☯ (~> (group 2 + _) (group 3 + _) @@ -104,27 +110,27 @@ for the forms are run. vs)) (define (run) - (run-benchmark group + (run-benchmark ~group check-values 200000))) -(module count "forms-base.rkt" +(module count "base.rkt" (provide run) - (define (count . vs) + (define (~count . vs) (apply (☯ count) vs)) (define (run) - (run-benchmark count + (run-benchmark ~count check-values 1000000))) -(module relay "forms-base.rkt" +(module relay "base.rkt" (provide run) - (define (relay . vs) + (define (~relay . vs) (apply (☯ (== add1 sub1 @@ -139,14 +145,14 @@ for the forms are run. vs)) (define (run) - (run-benchmark relay + (run-benchmark ~relay check-values 50000))) -(module relay* "forms-base.rkt" +(module relay* "base.rkt" (provide run) - (define (relay* . vs) + (define (~relay* . vs) (apply (☯ (==* add1 sub1 @@ -155,40 +161,40 @@ for the forms are run. vs)) (define (run) - (run-benchmark relay* + (run-benchmark ~relay* check-values 50000))) -(module amp "forms-base.rkt" +(module amp "base.rkt" (provide run) - (define (amp . vs) + (define (~amp . vs) (apply (☯ (>< sqr)) vs)) (define (run) - (run-benchmark amp + (run-benchmark ~amp check-values 300000))) -(module ground "forms-base.rkt" +(module ground "base.rkt" (provide run) - (define (ground . vs) + (define (~ground . vs) (apply (☯ ⏚) vs)) (define (run) - (run-benchmark ground + (run-benchmark ~ground check-values 200000))) -(module thread "forms-base.rkt" +(module thread "base.rkt" (provide run) - (define (thread . vs) + (define (~thread . vs) (apply (☯ (~> (+ 5) add1 @@ -204,14 +210,14 @@ for the forms are run. vs)) (define (run) - (run-benchmark thread + (run-benchmark ~thread check-values 200000))) -(module thread-right "forms-base.rkt" +(module thread-right "base.rkt" (provide run) - (define (thread-right . vs) + (define (~thread-right . vs) (apply (☯ (~>> (+ 5) add1 @@ -227,255 +233,255 @@ for the forms are run. vs)) (define (run) - (run-benchmark thread-right + (run-benchmark ~thread-right check-values 200000))) -(module crossover "forms-base.rkt" +(module crossover "base.rkt" (provide run) - (define (crossover . vs) + (define (~crossover . vs) (apply (☯ X) vs)) (define (run) - (run-benchmark crossover + (run-benchmark ~crossover check-values 200000))) -(module all "forms-base.rkt" +(module all "base.rkt" (provide run) - (define (all . vs) + (define (~all . vs) (apply (☯ (all positive?)) vs)) (define (run) - (run-benchmark all + (run-benchmark ~all check-values 200000))) -(module any "forms-base.rkt" +(module any "base.rkt" (provide run) - (define (any . vs) + (define (~any . vs) (apply (☯ (any positive?)) vs)) (define (run) - (run-benchmark any + (run-benchmark ~any check-values 200000))) -(module none "forms-base.rkt" +(module none "base.rkt" (provide run) - (define (none . vs) + (define (~none . vs) (apply (☯ (none positive?)) vs)) (define (run) - (run-benchmark none + (run-benchmark ~none check-values 200000))) -(module all? "forms-base.rkt" +(module all? "base.rkt" (provide run) - (define (all? . vs) + (define (~all? . vs) (apply (☯ all?) vs)) (define (run) - (run-benchmark all? + (run-benchmark ~all? check-values 200000))) -(module any? "forms-base.rkt" +(module any? "base.rkt" (provide run) - (define (any? . vs) + (define (~any? . vs) (apply (☯ any?) vs)) (define (run) - (run-benchmark any? + (run-benchmark ~any? check-values 200000))) -(module none? "forms-base.rkt" +(module none? "base.rkt" (provide run) - (define (none? . vs) + (define (~none? . vs) (apply (☯ none?) vs)) (define (run) - (run-benchmark none? + (run-benchmark ~none? check-values 200000))) -(module collect "forms-base.rkt" +(module collect "base.rkt" (provide run) - (define (collect . vs) + (define (~collect . vs) (apply (☯ ▽) vs)) (define (run) - (run-benchmark collect + (run-benchmark ~collect check-values 1000000))) -(module sep "forms-base.rkt" +(module sep "base.rkt" (provide run) - (define (sep v) + (define (~sep v) ((☯ △) v)) (define (run) - (run-benchmark sep + (run-benchmark ~sep check-list 1000000))) -(module gen "forms-base.rkt" +(module gen "base.rkt" (provide run) - (define (gen . vs) + (define (~gen . vs) (apply (☯ (gen 1 2 3)) vs)) (define (run) - (run-benchmark gen + (run-benchmark ~gen check-values 1000000))) -(module esc "forms-base.rkt" +(module esc "base.rkt" (provide run) - (define (esc . vs) + (define (~esc . vs) (apply (☯ (esc (λ args args))) vs)) (define (run) - (run-benchmark esc + (run-benchmark ~esc check-values 1000000))) -(module AND "forms-base.rkt" +(module AND "base.rkt" (provide run) - (define (AND . vs) + (define (~AND . vs) (apply (☯ AND) vs)) (define (run) - (run-benchmark AND + (run-benchmark ~AND check-values 200000))) -(module OR "forms-base.rkt" +(module OR "base.rkt" (provide run) - (define (OR . vs) + (define (~OR . vs) (apply (☯ OR) vs)) (define (run) - (run-benchmark OR + (run-benchmark ~OR check-values 200000))) -(module NOT "forms-base.rkt" +(module NOT "base.rkt" (provide run) - (define (NOT v) + (define (~NOT v) ((☯ NOT) v)) (define (run) - (run-benchmark NOT + (run-benchmark ~NOT check-value 200000))) -(module NAND "forms-base.rkt" +(module NAND "base.rkt" (provide run) - (define (NAND . vs) + (define (~NAND . vs) (apply (☯ NAND) vs)) (define (run) - (run-benchmark NAND + (run-benchmark ~NAND check-values 200000))) -(module NOR "forms-base.rkt" +(module NOR "base.rkt" (provide run) - (define (NOR . vs) + (define (~NOR . vs) (apply (☯ NOR) vs)) (define (run) - (run-benchmark NOR + (run-benchmark ~NOR check-values 200000))) -(module XOR "forms-base.rkt" +(module XOR "base.rkt" (provide run) - (define (XOR . vs) + (define (~XOR . vs) (apply (☯ XOR) vs)) (define (run) - (run-benchmark XOR + (run-benchmark ~XOR check-values 200000))) -(module XNOR "forms-base.rkt" +(module XNOR "base.rkt" (provide run) - (define (XNOR . vs) + (define (~XNOR . vs) (apply (☯ XNOR) vs)) (define (run) - (run-benchmark XNOR + (run-benchmark ~XNOR check-values 200000))) -(module tee "forms-base.rkt" +(module tee "base.rkt" (provide run) - (define (tee v) + (define (~tee v) ((☯ (-< add1 sub1 sqr)) v)) (define (run) - (run-benchmark tee + (run-benchmark ~tee check-value 200000))) -(module try "forms-base.rkt" +(module try "base.rkt" (provide run) (define (try-happy . vs) @@ -498,7 +504,7 @@ for the forms are run. (try-happy check-values 20000) (try-error check-values 20000)))) -(module currying "forms-base.rkt" +(module currying "base.rkt" (provide run) (define (currying . vs) @@ -509,7 +515,7 @@ for the forms are run. check-values 200000))) -(module template "forms-base.rkt" +(module template "base.rkt" (provide run) (define (template . vs) @@ -520,7 +526,7 @@ for the forms are run. check-values 200000))) -(module catchall-template "forms-base.rkt" +(module catchall-template "base.rkt" (provide run) (define (catchall-template . vs) @@ -531,43 +537,43 @@ for the forms are run. check-values 200000))) -(module if "forms-base.rkt" +(module if "base.rkt" (provide run) - (define (if . vs) + (define (~if . vs) (apply (☯ (if < 'hi 'bye)) vs)) (define (run) - (run-benchmark if + (run-benchmark ~if check-values 500000))) -(module when "forms-base.rkt" +(module when "base.rkt" (provide run) - (define (when . vs) + (define (~when . vs) (apply (☯ (when < 'hi)) vs)) (define (run) - (run-benchmark when + (run-benchmark ~when check-values 500000))) -(module unless "forms-base.rkt" +(module unless "base.rkt" (provide run) - (define (unless . vs) + (define (~unless . vs) (apply (☯ (unless < 'hi)) vs)) (define (run) - (run-benchmark unless + (run-benchmark ~unless check-values 500000))) -(module switch "forms-base.rkt" +(module switch "base.rkt" (provide run) (define (switch-basic . vs) @@ -595,41 +601,41 @@ for the forms are run. (switch-else check-values 200000) (switch-divert check-values 200000)))) -(module sieve "forms-base.rkt" +(module sieve "base.rkt" (provide run) - (define (sieve . vs) + (define (~sieve . vs) (apply (☯ (sieve positive? 'hi 'bye)) vs)) (define (run) - (run-benchmark sieve + (run-benchmark ~sieve check-values 100000))) -(module partition "forms-base.rkt" +(module partition "base.rkt" (provide run) - (define (partition . vs) + (define (~partition . vs) (apply (flow (partition [negative? *] [zero? count] [positive? +])) vs)) (define (run) - (run-benchmark partition check-values 100000))) + (run-benchmark ~partition check-values 100000))) -(module gate "forms-base.rkt" +(module gate "base.rkt" (provide run) - (define (gate . vs) + (define (~gate . vs) (apply (☯ (gate <)) vs)) (define (run) - (run-benchmark gate + (run-benchmark ~gate check-values 500000))) -(module input-aliases "forms-base.rkt" +(module input-aliases "base.rkt" (provide run) (define (input-alias-1 . vs) @@ -657,7 +663,7 @@ for the forms are run. check-values 100000)))) -(module fanout "forms-base.rkt" +(module fanout "base.rkt" (provide run) (define (fanout-small-n . vs) @@ -678,19 +684,19 @@ for the forms are run. check-values 20000)))) -(module inverter "forms-base.rkt" +(module inverter "base.rkt" (provide run) - (define (inverter . vs) + (define (~inverter . vs) (apply (☯ inverter) vs)) (define (run) - (run-benchmark inverter + (run-benchmark ~inverter check-values 200000))) -(module feedback "forms-base.rkt" +(module feedback "base.rkt" (provide run) (define (feedback-number . vs) @@ -719,130 +725,130 @@ for the forms are run. check-value 70000)))) -(module select "forms-base.rkt" +(module select "base.rkt" (provide run) - (define (select . vs) + (define (~select . vs) (apply (☯ (select 3 5 8)) vs)) (define (run) - (run-benchmark select + (run-benchmark ~select check-values 20000))) -(module block "forms-base.rkt" +(module block "base.rkt" (provide run) - (define (block . vs) + (define (~block . vs) (apply (☯ (block 3 5 8)) vs)) (define (run) - (run-benchmark block + (run-benchmark ~block check-values 20000))) -(module bundle "forms-base.rkt" +(module bundle "base.rkt" (provide run) - (define (bundle . vs) + (define (~bundle . vs) (apply (☯ (bundle (3 5 8) + -)) vs)) (define (run) - (run-benchmark bundle + (run-benchmark ~bundle check-values 20000))) -(module effect "forms-base.rkt" +(module effect "base.rkt" (provide run) - (define (effect . vs) + (define (~effect . vs) (apply (☯ (effect + +)) vs)) (define (run) - (run-benchmark effect + (run-benchmark ~effect check-values 200000))) -(module live? "forms-base.rkt" +(module live? "base.rkt" (provide run) - (define (live? . vs) + (define (~live? . vs) (apply (☯ live?) vs)) (define (run) - (run-benchmark live? + (run-benchmark ~live? check-values 500000))) -(module rectify "forms-base.rkt" +(module rectify "base.rkt" (provide run) - (define (rectify . vs) + (define (~rectify . vs) (apply (☯ (rectify #f)) vs)) (define (run) - (run-benchmark rectify + (run-benchmark ~rectify check-values 500000))) -(module pass "forms-base.rkt" +(module pass "base.rkt" (provide run) - (define (pass . vs) + (define (~pass . vs) (apply (☯ (pass odd?)) vs)) (define (run) - (run-benchmark pass + (run-benchmark ~pass check-values 200000))) -(module foldl "forms-base.rkt" +(module foldl "base.rkt" (provide run) - (define (>> . vs) + (define (~foldl . vs) (apply (☯ (>> +)) vs)) (define (run) - (run-benchmark >> + (run-benchmark ~foldl check-values 200000))) -(module foldr "forms-base.rkt" +(module foldr "base.rkt" (provide run) - (define (<< . vs) + (define (~foldr . vs) (apply (☯ (<< +)) vs)) (define (run) - (run-benchmark << + (run-benchmark ~foldr check-values 200000))) -(module loop "forms-base.rkt" +(module loop "base.rkt" (provide run) - (define (loop . vs) + (define (~loop . vs) (apply (☯ (loop live? sqr)) vs)) (define (run) - (run-benchmark loop + (run-benchmark ~loop check-values 100000))) -(module loop2 "forms-base.rkt" +(module loop2 "base.rkt" (provide run) - (define (loop2 . vs) + (define (~loop2 . vs) ((☯ (~> (loop2 (~> 1> (not null?)) sqr +))) @@ -850,46 +856,51 @@ for the forms are run. 0)) (define (run) - (run-benchmark loop2 + (run-benchmark ~loop2 check-values 100000))) -(module apply "forms-base.rkt" +(module apply "base.rkt" (provide run) (require (only-in racket/base [apply b:apply])) - (define (apply . vs) + (define (~apply . vs) (b:apply (☯ apply) (cons + vs))) (define (run) - (run-benchmark apply + (run-benchmark ~apply check-values 300000))) -(module clos "forms-base.rkt" +(module clos "base.rkt" (provide run) ;; TODO: this uses a lot of other things besides `clos` and is ;; likely not a reliable indicator - (define (clos . vs) + (define (~clos . vs) (apply (☯ (~> (-< (~> 5 (clos *)) _) apply)) vs)) (define (run) - (run-benchmark clos + (run-benchmark ~clos check-values 100000))) -;; To run benchmarks for a form interactively, use e.g.: -;; (require (submod "." fanout)) -;; (run) +(module main racket/base -(module* main cli + (provide benchmark) + (require racket/match + racket/format + relation + qi + (only-in "../util.rkt" + only-if + for/call)) (require (prefix-in one-of?: (submod ".." one-of?)) (prefix-in and: (submod ".." and)) @@ -953,14 +964,6 @@ for the forms are run. (prefix-in apply: (submod ".." apply)) (prefix-in clos: (submod ".." clos))) - (require racket/match - racket/format - relation - qi - (only-in "util.rkt" - only-if - for/call)) - ;; It would be great if we could get the value of a variable ;; by using its (string) name, but (eval (string->symbol name)) ;; doesn't find it. So instead, we reify the "lexical environment" @@ -1031,19 +1034,17 @@ for the forms are run. "apply" apply:run "clos" clos:run)) - (flag (forms #:param [forms null] name) - ("-f" "--form" "Forms to benchmark") - (forms (cons name (forms)))) - - (constraint (multi forms)) - - (program (main) - (let ([fs (~>> ((forms)) - (only-if null? - (gen (hash-keys env))) - (sort <))]) - (for ([f fs]) - (match-let ([(list name ms) ((hash-ref env f))]) - (displayln (~a name ": " ms " ms")))))) - - (run main)) + (define (benchmark forms) + (define fs (~>> (forms) + (only-if null? + (gen (hash-keys env))) + (sort <))) + (define forms-data (for/list ([f (in-list fs)]) + (match-let ([(list name ms) ((hash-ref env f))]) + ;; Print results "live" to STDERR, with + ;; only the actual output (if desired) + ;; going to STDOUT at the end. + (displayln (~a name ": " ms " ms") + (current-error-port)) + (hash 'name name 'unit "ms" 'value ms)))) + forms-data)) diff --git a/qi-sdk/profile/local/report.rkt b/qi-sdk/profile/local/report.rkt new file mode 100755 index 00000000..2ff1e96e --- /dev/null +++ b/qi-sdk/profile/local/report.rkt @@ -0,0 +1,46 @@ +#!/usr/bin/env racket +#lang cli + +(require racket/format + (only-in "../util.rkt" + format-output) + "../regression.rkt" + (submod "benchmarks.rkt" main)) + +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select form to benchmark") + (selected (cons name (selected)))) + +(constraint (multi selected)) + +(help + (usage + (~a "Run benchmarks for individual Qi forms " + "(by default, all of them), reporting the results " + "in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(program (main) + (displayln "\nRunning local (forms) benchmarks..." (current-error-port)) + + (let ([output (benchmark (selected))]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (format-output (compute-regression before after) + (output-format))) + (format-output output (output-format))))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "fanout")) + +(run main) diff --git a/qi-sdk/profile/nonlocal/intrinsic.rkt b/qi-sdk/profile/nonlocal/intrinsic.rkt new file mode 100755 index 00000000..b5c04ad1 --- /dev/null +++ b/qi-sdk/profile/nonlocal/intrinsic.rkt @@ -0,0 +1,55 @@ +#!/usr/bin/env racket +#lang racket/base + +(provide benchmark) + +(require racket/runtime-path + "../util.rkt" + "spec.rkt") + +;; We use `eval` in this module to `require` the appropriate objective +;; functions (either Racket or Qi) for benchmarking in a dynamically +;; constructed namespace (following +;; https://docs.racket-lang.org/guide/eval.html). This allows us to +;; define those functions symmetrically in the Racket and Qi modules, and +;; invoke them in a common way here. But as this eval namespace is +;; dynamically constructed, the require paths are interpreted as being +;; relative to the path from which this module is executed (e.g. either +;; locally from this folder or from the qi root via the Makefile) and may +;; therefore fail to find the modules if executed from "the wrong" +;; location. To avoid this, we set the "load relative" directory to the +;; module's path, so that requiring modules is always relative to the +;; present module path, allowing it to behave the same no matter where it +;; is executed from. Another possibility is to simply assume that the +;; qi-sdk package is installed so that the modules are available via +;; collection paths, but currently, having the SDK "officially" installed +;; slows down building of other packages for reasons as yet unknown. See: +;; https://github.com/drym-org/qi/wiki/Installing-the-SDK#install-the-sdk +;; So for now, we use this fix so that we can have the SDK remain +;; uninstalled. + +(define-runtime-path lexical-module-path ".") + +(define (benchmark language benchmarks-to-run) + (let ([namespace (make-base-namespace)] + [benchmarks-to-run (if (null? benchmarks-to-run) + (map bm-name specs) + benchmarks-to-run)]) + (cond [(equal? "qi" language) + (parameterize ([current-load-relative-directory lexical-module-path]) + (eval '(require "qi/main.rkt") + namespace))] + [(equal? "racket" language) + (parameterize ([current-load-relative-directory lexical-module-path]) + (eval '(require "racket/main.rkt") + namespace))]) + + (for/list ([spec specs] + #:when (member (bm-name spec) benchmarks-to-run)) + (let ([name (bm-name spec)] + [exerciser (bm-exerciser spec)] + [f (eval + ;; the first datum in the benchmark name needs to be a function name + (read (open-input-string (bm-name spec))) namespace)] + [n-times (bm-times spec)]) + (run-nonlocal-benchmark name exerciser f n-times))))) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt new file mode 100644 index 00000000..7d9f154a --- /dev/null +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -0,0 +1,111 @@ +#lang racket/base + +(provide conditionals + composition + root-mean-square + factorial + pingala + eratosthenes + collatz + range-map-car + filter-map + filter-map-foldr + filter-map-foldl + long-functional-pipeline + filter-map-values + range-map-sum + double-list + double-values) + +(require (only-in math sqr) + (only-in racket/list range) + qi) + +(define-switch conditionals + [(< 5) sqr] + [(> 5) add1] + [else _]) + +(define-flow composition + (~> add1 sqr sub1)) + +(define-flow root-mean-square + (~> (-< (~>> △ (>< sqr) +) + length) / sqrt)) + +(define-switch factorial + [(< 2) 1] + [else (~> (-< _ (~> sub1 factorial)) *)]) + +(define-switch pingala + [(< 2) _] + [else (~> (-< sub1 + (- 2)) (>< pingala) +)]) + +(define-flow (eratosthenes n) + (~> (-< (gen null) (~>> add1 (range 2) △)) + (feedback (while (~> (block 1) live?)) + (then (~> 1> reverse)) + (-< (~> (select 1 2) X cons) + (~> (-< (~>> 2> (clos (~> remainder (not (= 0))))) + (block 1 2)) pass))))) + +(define-flow collatz + (switch + [(<= 1) list] + [odd? (~> (-< _ (~> (* 3) (+ 1) collatz)) + cons)] + [even? (~> (-< _ (~> (quotient 2) collatz)) + cons)])) + + +;; (define-flow filter-map +;; (~> △ (>< (if odd? sqr ⏚)) ▽)) + +(define-flow filter-map + (~>> (filter odd?) + (map sqr))) + +(define-flow filter-map-foldr + (~>> (filter odd?) + (map sqr) + (foldr + 0))) + +(define-flow filter-map-foldl + (~>> (filter odd?) + (map sqr) + (foldl + 0))) + +(define-flow range-map-car + (~>> (range 0) + (map sqr) + car)) + +(define-flow range-map-sum + ;; TODO: this should be written as (apply +) + ;; and that should be normalized to (foldr/l + 0) + ;; (depending on which of foldl/foldr is more performant) + (~>> (range 0) (map sqr) (foldr + 0))) + +(define-flow long-functional-pipeline + (~>> (range 0) + (filter odd?) + (map sqr) + values + (filter (λ (v) (< (remainder v 10) 5))) + (map (λ (v) (* 2 v))) + (foldl + 0))) + +;; (define filter-double +;; (map (☯ (when odd? +;; (-< _ _))) +;; (list 1 2 3 4 5))) + +(define-flow filter-map-values + (>< (if odd? sqr ⏚))) + +(define-flow double-list + (~> △ (>< (-< _ _)) ▽)) + +(define-flow double-values + (>< (-< _ _))) diff --git a/qi-sdk/profile/builtin.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt similarity index 53% rename from qi-sdk/profile/builtin.rkt rename to qi-sdk/profile/nonlocal/racket/main.rkt index 30351831..89769805 100644 --- a/qi-sdk/profile/builtin.rkt +++ b/qi-sdk/profile/nonlocal/racket/main.rkt @@ -1,14 +1,19 @@ #lang racket/base -(provide cond-fn - compose-fn +(provide conditionals + composition root-mean-square - fact - ping - eratos + factorial + pingala + eratosthenes collatz - filter-map-fn + range-map-car + filter-map + filter-map-foldr + filter-map-foldl + long-functional-pipeline filter-map-values + range-map-sum double-list double-values) @@ -16,30 +21,30 @@ racket/list racket/match) -(define (cond-fn x) +(define (conditionals x) (cond [(< x 5) (sqr x)] [(> x 5) (add1 x)] [else x])) -(define (compose-fn v) +(define (composition v) (sub1 (sqr (add1 v)))) (define (root-mean-square vs) (sqrt (/ (apply + (map sqr vs)) (length vs)))) -(define (fact n) +(define (factorial n) (if (< n 2) 1 - (* (fact (sub1 n)) n))) + (* (factorial (sub1 n)) n))) -(define (ping n) +(define (pingala n) (if (< n 2) n - (+ (ping (sub1 n)) - (ping (- n 2))))) + (+ (pingala (sub1 n)) + (pingala (- n 2))))) -(define (eratos n) +(define (eratosthenes n) (let ([lst (range 2 (add1 n))]) (let loop ([rem lst] [result null]) @@ -55,9 +60,31 @@ [(odd? n) (cons n (collatz (+ (* 3 n) 1)))] [(even? n) (cons n (collatz (quotient n 2)))])) -(define (filter-map-fn lst) +(define (filter-map lst) (map sqr (filter odd? lst))) +(define (filter-map-foldr lst) + (foldr + 0 (map sqr (filter odd? lst)))) + +(define (filter-map-foldl lst) + (foldl + 0 (map sqr (filter odd? lst)))) + +(define (range-map-car v) + (car (map sqr (range 0 v)))) + +(define (range-map-sum n) + (apply + (map sqr (range 0 n)))) + +(define (long-functional-pipeline v) + (foldl + + 0 + (map (λ (v) (* 2 v)) + (filter (λ (v) (< (remainder v 10) 5)) + (values + (map sqr + (filter odd? + (range 0 v)))))))) + (define (filter-map-values . vs) (apply values (map sqr (filter odd? vs)))) diff --git a/qi-sdk/profile/nonlocal/report-competitive.rkt b/qi-sdk/profile/nonlocal/report-competitive.rkt new file mode 100755 index 00000000..7e03033f --- /dev/null +++ b/qi-sdk/profile/nonlocal/report-competitive.rkt @@ -0,0 +1,44 @@ +#!/usr/bin/env racket +#lang cli + +(require racket/format + (only-in "../util.rkt" + format-output) + "../regression.rkt" + "intrinsic.rkt") + +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select benchmark by name") + (selected (cons name (selected)))) + +(constraint (multi selected)) + +(help + (usage + (~a "Run competitive benchmarks between Qi and Racket, " + "reporting the results in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(program (main) + (displayln "\nRunning competitive benchmarks..." (current-error-port)) + + (let* ([racket-output + (begin (displayln "\nRunning Racket benchmarks..." (current-error-port)) + (benchmark "racket" (selected)))] + [qi-output + (begin (displayln "\nRunning Qi benchmarks..." (current-error-port)) + (benchmark "qi" (selected)))] + [before (parse-benchmarks racket-output)] + [after (parse-benchmarks qi-output)]) + (format-output (compute-regression before after) + (output-format)))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "composition")) + +(run main) diff --git a/qi-sdk/profile/nonlocal/report-intrinsic.rkt b/qi-sdk/profile/nonlocal/report-intrinsic.rkt new file mode 100755 index 00000000..c451cd71 --- /dev/null +++ b/qi-sdk/profile/nonlocal/report-intrinsic.rkt @@ -0,0 +1,51 @@ +#!/usr/bin/env racket +#lang cli + +(require racket/format + (only-in "../util.rkt" + format-output) + "../regression.rkt" + "intrinsic.rkt") + +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select benchmark by name") + (selected (cons name (selected)))) + +(constraint (multi selected)) + +(help + (usage + (~a "Run nonlocal benchmarks on either Qi or Racket, " + "reporting the results in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(flag (language #:param [language "qi"] lang) + ("-l" + "--language" + "Language to benchmark, either 'qi' or 'racket'. If none is specified, assumes 'qi'.") + (language lang)) + +(program (main) + (displayln "\nRunning nonlocal benchmarks..." (current-error-port)) + + (let ([output (benchmark (language) (selected))]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (format-output (compute-regression before after) + (output-format))) + (format-output output (output-format))))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "composition")) + +(run main) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt new file mode 100644 index 00000000..eb7b5388 --- /dev/null +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -0,0 +1,65 @@ +#lang racket/base + +(provide specs + (struct-out bm)) + +(require "../util.rkt") + +(struct bm (name exerciser times) + #:transparent) + +(define specs + ;; the first datum in the benchmark name needs to be the name + ;; of the function that will be exercised + (list (bm "conditionals" + check-value + 300000) + (bm "composition" + check-value + 300000) + (bm "root-mean-square" + check-list + 500000) + (bm "range-map-car" + check-value-large + 50000) + (bm "filter-map" + check-list + 500000) + (bm "filter-map (large list)" + check-large-list + 50000) + (bm "filter-map-foldr" + check-large-list + 50000) + (bm "filter-map-foldl" + check-large-list + 50000) + (bm "long-functional-pipeline" + check-value-large + 5000) + (bm "range-map-sum" + check-value-large + 5000) + (bm "filter-map-values" + check-values + 500000) + (bm "double-list" + check-list + 500000) + (bm "double-values" + check-values + 500000) + (bm "factorial" + check-value + 100000) + (bm "pingala" + check-value + 10000) + (bm "eratosthenes" + check-value-medium-large + 100) + ;; See https://en.wikipedia.org/wiki/Collatz_conjecture + (bm "collatz" + check-value + 10000))) diff --git a/qi-sdk/profile/qi.rkt b/qi-sdk/profile/qi.rkt deleted file mode 100644 index d15594bb..00000000 --- a/qi-sdk/profile/qi.rkt +++ /dev/null @@ -1,67 +0,0 @@ -#lang racket/base - -(provide cond-fn - compose-fn - root-mean-square - fact - ping - eratos - collatz - filter-map-fn - filter-map-values - double-list - double-values) - -(require (only-in math sqr) - (only-in racket/list range) - qi) - -(define-switch cond-fn - [(< 5) sqr] - [(> 5) add1] - [else _]) - -(define-flow compose-fn - (~> add1 sqr sub1)) - -(define-flow root-mean-square - (~> (-< (~>> △ (>< sqr) +) - length) / sqrt)) - -(define-switch fact - [(< 2) 1] - [else (~> (-< _ (~> sub1 fact)) *)]) - -(define-switch ping - [(< 2) _] - [else (~> (-< sub1 - (- 2)) (>< ping) +)]) - -(define-flow (eratos n) - (~> (-< (gen null) (~>> add1 (range 2) △)) - (feedback (while (~> (block 1) live?)) - (then (~> 1> reverse)) - (-< (~> (select 1 2) X cons) - (~> (-< (~>> 2> (clos (~> remainder (not (= 0))))) - (block 1 2)) pass))))) - -(define-flow collatz - (switch - [(<= 1) list] - [odd? (~> (-< _ (~> (* 3) (+ 1) collatz)) - cons)] - [even? (~> (-< _ (~> (quotient 2) collatz)) - cons)])) - - -(define-flow filter-map-fn - (~> △ (>< (if odd? sqr ⏚)) ▽)) - -(define-flow filter-map-values - (>< (if odd? sqr ⏚))) - -(define-flow double-list - (~> △ (>< (-< _ _)) ▽)) - -(define-flow double-values - (>< (-< _ _))) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt new file mode 100644 index 00000000..20ec8b6c --- /dev/null +++ b/qi-sdk/profile/regression.rkt @@ -0,0 +1,74 @@ +#!/usr/bin/env racket +#lang racket/base + +(provide parse-json-file + parse-benchmarks + compute-regression) + +(require qi + relation + json + racket/format + racket/pretty) + +(define LOWER-THRESHOLD 0.75) +(define HIGHER-THRESHOLD 1.33) + +(define (parse-json-file filename) + (call-with-input-file filename + (λ (port) + (read-json port)))) + +(define (parse-benchmarks benchmarks) + ;; renames some forms so they're consistently named + ;; but otherwise leaves the original data unmodified + (make-hash + (map (☯ (~> (-< (~> (hash-ref 'name) + (switch + [(equal? "foldr") "<<"] ; these were renamed at some point + [(equal? "foldl") ">>"] ; so rename them back to match them + [else _])) + (hash-ref 'value)) + cons)) + benchmarks))) + +(define (compute-regression before + after + [low LOWER-THRESHOLD] + [high HIGHER-THRESHOLD]) + + (define-flow calculate-ratio + (~> (-< (hash-ref after _) + (~> (hash-ref before _) + ;; avoid division by zero + (if (= 0) 1 _))) + / + (if (< low _ high) + 1 + (~r #:precision 2)))) + + (define-flow reformat + (~> △ + (>< (~> (-< car cadr) + (hash 'name _ 'value _ 'unit "x"))) + ▽)) + + (define (show-results results) + (displayln "\nPerformance relative to baseline:" (current-error-port)) + (pretty-display results (current-error-port))) + + (define results + (~>> (after) + hash-keys + △ + (>< + (~> + (-< _ + calculate-ratio) + ▽)) + ▽ + (sort > #:key (☯ (~> cadr ->inexact))) + (ε show-results) + reformat)) + + results) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt old mode 100644 new mode 100755 index 82ed4b2d..1208491a --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -1,158 +1,69 @@ +#!/usr/bin/env racket #lang cli -(require - (prefix-in one-of?: (submod "forms.rkt" one-of?)) - (prefix-in and: (submod "forms.rkt" and)) - (prefix-in or: (submod "forms.rkt" or)) - (prefix-in not: (submod "forms.rkt" not)) - (prefix-in and%: (submod "forms.rkt" and%)) - (prefix-in or%: (submod "forms.rkt" or%)) - (prefix-in group: (submod "forms.rkt" group)) - (prefix-in count: (submod "forms.rkt" count)) - (prefix-in relay: (submod "forms.rkt" relay)) - (prefix-in relay*: (submod "forms.rkt" relay*)) - (prefix-in amp: (submod "forms.rkt" amp)) - (prefix-in ground: (submod "forms.rkt" ground)) - (prefix-in thread: (submod "forms.rkt" thread)) - (prefix-in thread-right: (submod "forms.rkt" thread-right)) - (prefix-in crossover: (submod "forms.rkt" crossover)) - (prefix-in all: (submod "forms.rkt" all)) - (prefix-in any: (submod "forms.rkt" any)) - (prefix-in none: (submod "forms.rkt" none)) - (prefix-in all?: (submod "forms.rkt" all?)) - (prefix-in any?: (submod "forms.rkt" any?)) - (prefix-in none?: (submod "forms.rkt" none?)) - (prefix-in collect: (submod "forms.rkt" collect)) - (prefix-in sep: (submod "forms.rkt" sep)) - (prefix-in gen: (submod "forms.rkt" gen)) - (prefix-in esc: (submod "forms.rkt" esc)) - (prefix-in AND: (submod "forms.rkt" AND)) - (prefix-in OR: (submod "forms.rkt" OR)) - (prefix-in NOT: (submod "forms.rkt" NOT)) - (prefix-in NAND: (submod "forms.rkt" NAND)) - (prefix-in NOR: (submod "forms.rkt" NOR)) - (prefix-in XOR: (submod "forms.rkt" XOR)) - (prefix-in XNOR: (submod "forms.rkt" XNOR)) - (prefix-in tee: (submod "forms.rkt" tee)) - (prefix-in try: (submod "forms.rkt" try)) - (prefix-in currying: (submod "forms.rkt" currying)) - (prefix-in template: (submod "forms.rkt" template)) - (prefix-in catchall-template: (submod "forms.rkt" catchall-template)) - (prefix-in if: (submod "forms.rkt" if)) - (prefix-in when: (submod "forms.rkt" when)) - (prefix-in unless: (submod "forms.rkt" unless)) - (prefix-in switch: (submod "forms.rkt" switch)) - (prefix-in sieve: (submod "forms.rkt" sieve)) - (prefix-in partition: (submod "forms.rkt" partition)) - (prefix-in gate: (submod "forms.rkt" gate)) - (prefix-in input-aliases: (submod "forms.rkt" input-aliases)) - (prefix-in fanout: (submod "forms.rkt" fanout)) - (prefix-in inverter: (submod "forms.rkt" inverter)) - (prefix-in feedback: (submod "forms.rkt" feedback)) - (prefix-in select: (submod "forms.rkt" select)) - (prefix-in block: (submod "forms.rkt" block)) - (prefix-in bundle: (submod "forms.rkt" bundle)) - (prefix-in effect: (submod "forms.rkt" effect)) - (prefix-in live?: (submod "forms.rkt" live?)) - (prefix-in rectify: (submod "forms.rkt" rectify)) - (prefix-in pass: (submod "forms.rkt" pass)) - (prefix-in foldl: (submod "forms.rkt" foldl)) - (prefix-in foldr: (submod "forms.rkt" foldr)) - (prefix-in loop: (submod "forms.rkt" loop)) - (prefix-in loop2: (submod "forms.rkt" loop2)) - (prefix-in apply: (submod "forms.rkt" apply)) - (prefix-in clos: (submod "forms.rkt" clos))) - -(require "loadlib.rkt") - -(require racket/match - racket/format +(require racket/format relation - qi - json (only-in "util.rkt" - only-if - for/call)) + format-output) + "loading/loadlib.rkt" + "regression.rkt" + (submod "local/benchmarks.rkt" main) + (prefix-in n: "nonlocal/intrinsic.rkt")) + +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select form to benchmark") + (selected (cons name (selected)))) + +(constraint (multi selected)) + +(help + (usage + (~a "Run benchmarks for individual Qi forms " + "(by default, all of them), reporting the results " + "in a configurable output format."))) -;; It would be great if we could get the value of a variable -;; by using its (string) name, but (eval (string->symbol name)) -;; doesn't find it. So instead, we reify the "lexical environment" -;; here manually, so that the values can be looked up at runtime -;; based on the string names (note that the value is always the key -;; + ":" + "run") -(define env - (hash - "one-of?" one-of?:run - "and" and:run - "or" or:run - "not" not:run - "and%" and%:run - "or%" or%:run - "group" group:run - "count" count:run - "relay" relay:run - "relay*" relay*:run - "amp" amp:run - "ground" ground:run - "thread" thread:run - "thread-right" thread-right:run - "crossover" crossover:run - "all" all:run - "any" any:run - "none" none:run - "all?" all?:run - "any?" any?:run - "none?" none?:run - "collect" collect:run - "sep" sep:run - "gen" gen:run - "esc" esc:run - "AND" AND:run - "OR" OR:run - "NOT" NOT:run - "NAND" NAND:run - "NOR" NOR:run - "XOR" XOR:run - "XNOR" XNOR:run - "tee" tee:run - "try" try:run - "currying" currying:run - "template" template:run - "catchall-template" catchall-template:run - "if" if:run - "when" when:run - "unless" unless:run - "switch" switch:run - "sieve" sieve:run - "partition" partition:run - "gate" gate:run - "input-aliases" input-aliases:run - "fanout" fanout:run - "inverter" inverter:run - "feedback" feedback:run - "select" select:run - "block" block:run - "bundle" bundle:run - "effect" effect:run - "live?" live?:run - "rectify" rectify:run - "pass" pass:run - "foldl" foldl:run - "foldr" foldr:run - "loop" loop:run - "loop2" loop2:run - "apply" apply:run - "clos" clos:run)) +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) +(flag (type #:param [report-type "all"] typ) + ("-t" + "--type" + "Type of report, either `local`, `nonlocal`, `loading` or `all` (default `all`)") + (report-type typ)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +;; Note: much of this file is duplicated across local/report.rkt +;; and loading/report.rkt. It could be avoided if we had +;; "composition of commands", see: +;; https://github.com/countvajhula/cli/issues/3 (program (main) - ;; Note: could use try-order? with hash-keys if support is dropped for Racket 8.3 - (define fs (~>> (env) hash-keys (sort <))) - (define forms-data (for/list ([f (in-list fs)]) - (match-let ([(list name ms) ((hash-ref env f))]) - (hash 'name name 'unit "ms" 'value ms)))) - (define require-data (list (hash 'name "(require qi)" - 'unit "ms" - 'value (time-module-ms "qi")))) - (write-json (append forms-data require-data))) + (displayln "\nRunning local (forms) benchmarks and measuring module load time..." + (current-error-port)) + + (let* ([local-data (if (member? (report-type) (list "all" "local")) + (benchmark (selected)) + null)] + [nonlocal-data (if (member? (report-type) (list "all" "nonlocal")) + (n:benchmark "qi" (selected)) + null)] + [require-data (if (member? (report-type) (list "all" "loading")) + (list (profile-load "qi")) + null)] + [output (~ local-data nonlocal-data require-data)]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (format-output (compute-regression before after) + (output-format))) + (format-output output (output-format))))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "fanout")) (run main) diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index 64720c82..27a0be0e 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -3,28 +3,35 @@ (provide average measure check-value + check-value-medium-large + check-value-large + check-value-very-large check-list + check-large-list check-values check-two-values run-benchmark run-summary-benchmark - run-competitive-benchmark + run-nonlocal-benchmark (for-space qi only-if) - for/call) + for/call + write-csv + format-output) (require (only-in racket/list range second) + (only-in racket/function + curryr) (only-in adjutor values->list) - (only-in data/collection - cycle - take - in) - racket/function + csv-writing + json racket/format syntax/parse/define - (for-syntax racket/base) + (for-syntax racket/base + (only-in racket/string + string-trim)) qi) (define-flow average @@ -53,6 +60,12 @@ (set! i (remainder (add1 i) len)) (fn (vector-ref inputs i))))) +(define check-value-medium-large (curryr check-value #(100 200 300))) + +(define check-value-large (curryr check-value #(1000))) + +(define check-value-very-large (curryr check-value #(100000))) + ;; This uses the same list input each time. Not sure if that ;; may end up being cached at some level and thus obfuscate ;; the results? On the other hand, @@ -64,6 +77,12 @@ (for ([i how-many]) (fn vs)))) +(define (check-large-list fn how-many) + ;; call a function with a single list argument + (let ([vs (range 1000)]) + (for ([i how-many]) + (fn vs)))) + ;; This uses the same input values each time. See the note ;; above for check-list in this connection. (define (check-values fn how-many) @@ -84,10 +103,22 @@ ;; Run a single benchmarking function a specified number of times ;; and report the time taken. +;; TODO: this is very similar to run-nonlocal-benchmark and these +;; should be unified. (define-syntax-parse-rule (run-benchmark f-name runner n-times) #:with name (datum->syntax #'f-name - (symbol->string - (syntax->datum #'f-name))) + ;; this is because of the name collision between + ;; Racket functions and Qi forms, now that the latter + ;; are provided as identifiers in the qi binding space. + ;; Using a standard prefix (i.e. ~) in the naming and then + ;; detecting that, trimming it, here, is pretty hacky. + ;; One alternative could be to broaden the run-benchmark + ;; macro to support a name argument, but that seems like + ;; more work. It would be better to be able to introspect + ;; these somehow. + (string-trim (symbol->string + (syntax->datum #'f-name)) + "~")) (let ([ms (measure runner f-name n-times)]) (list name ms))) @@ -107,20 +138,30 @@ ;; Run different implementations of the same benchmark (e.g. a Racket vs a Qi ;; implementation) a specified number of times, and report the time taken ;; by each implementation. -(define-syntax-parse-rule (run-competitive-benchmark name runner f-name n-times) - #:with f-builtin (datum->syntax #'name - (string->symbol - (string-append "b:" - (symbol->string - (syntax->datum #'f-name))))) - #:with f-qi (datum->syntax #'name - (string->symbol - (string-append "q:" - (symbol->string - (syntax->datum #'f-name))))) - (begin - (displayln (~a name ":")) - (for ([f (list f-builtin f-qi)] - [label (list "λ" "☯")]) - (let ([ms (measure runner f n-times)]) - (displayln (~a label ": " ms " ms")))))) +(define (run-nonlocal-benchmark name runner f n-times) + (displayln (~a name ":") (current-error-port)) + (let ([ms (measure runner f n-times)]) + (displayln (~a ms " ms") (current-error-port)) + (hash 'name name 'unit "ms" 'value ms))) + +(define (write-csv data) + (~> (data) + △ + (>< (~> (-< (hash-ref 'name) + (hash-ref 'unit) + (hash-ref 'value)) + ▽)) + (-< '(name unit value) + _) + ▽ + display-table)) + +(define (format-output output fmt) + ;; Note: this is a case where declaring "constraints" on the CLI args + ;; would be useful, instead of using the ad hoc fallback `else` check here + ;; https://github.com/countvajhula/cli/issues/6 + (cond + [(equal? fmt "json") (write-json output)] + [(equal? fmt "csv") (write-csv output)] + [(equal? fmt "") (values)] + [else (error (~a "Unrecognized format: " fmt "!"))])) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt new file mode 100644 index 00000000..8e6f191c --- /dev/null +++ b/qi-test/tests/compiler.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(provide tests) + +(require rackunit + rackunit/text-ui + (prefix-in semantics: "compiler/semantics.rkt") + (prefix-in rules: "compiler/rules.rkt") + (prefix-in pass: "compiler/pass.rkt") + (prefix-in impl: "compiler/impl.rkt")) + +(define tests + (test-suite + "compiler tests" + + semantics:tests + rules:tests + pass:tests + impl:tests)) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/compiler/impl.rkt b/qi-test/tests/compiler/impl.rkt new file mode 100644 index 00000000..052f6c0e --- /dev/null +++ b/qi-test/tests/compiler/impl.rkt @@ -0,0 +1,46 @@ +#lang racket/base + +(provide tests) + +(require qi/flow/core/impl + rackunit + rackunit/text-ui + (only-in racket/function thunk)) + +(define tests + (test-suite + "Compiler implementation functions tests" + ;; Most of these are tested implicitly via testing the Qi forms + ;; that compile to them. But some nuances of the implementation + ;; aren't hit by the unit tests, and it doesn't seem desirable + ;; to expand the form unit tests to cover these corner cases + ;; of the low-level implementation, so we test them more + ;; comprehensively here as needed. + + (test-suite + "arg" + (test-equal? "first argument" + ((arg 1) 0 3) + 0) + (test-equal? "second argument" + ((arg 2) 0 3) + 3) + (test-equal? "third argument" + ((arg 3) 0 3 5) + 5) + (test-exn "argument index too low - 1-indexed" + exn:fail? + (thunk ((arg 0) 0 3))) + (test-exn "argument index too high - 1" + exn:fail? + (thunk ((arg 1)))) + (test-exn "argument index too high - 2" + exn:fail? + (thunk ((arg 2)))) + (test-exn "argument index too high - 3" + exn:fail? + (thunk ((arg 3))))))) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/compiler/pass.rkt b/qi-test/tests/compiler/pass.rkt new file mode 100644 index 00000000..082da686 --- /dev/null +++ b/qi-test/tests/compiler/pass.rkt @@ -0,0 +1,103 @@ +#lang racket/base + +(provide tests) + +(require qi/flow/core/pass + rackunit + rackunit/text-ui + syntax/parse + syntax/parse/define + (for-syntax racket/base) + (only-in qi/flow/core/private/form-property tag-form-syntax) + (only-in racket/function + curry + curryr + thunk*)) + +;; NOTE: we need to tag test syntax with `tag-form-syntax` +;; in some cases. See the comment on that function definition. + +;; traverse syntax a and map it under the indicated parser patterns +;; using find-and-map/qi, and verify it results in syntax b +(define-syntax-parser test-syntax-map-equal? + [(_ name (pat ...) a b) + #:with f #'(syntax-parser pat ...) + #'(test-equal? name + (syntax->datum + (find-and-map/qi f (tag-form-syntax a))) + (syntax->datum b))]) + +(define tests + (test-suite + "Compiler pass utilities tests" + + (test-suite + "fixed point" + (check-equal? ((fix abs) -1) 1) + (check-equal? ((fix abs) -1) 1) + (let ([integer-div2 (compose floor (curryr / 2))]) + (check-equal? ((fix integer-div2) 10) + 0)) + (check-equal? ((fix (thunk* #f)) -1) + -1 + "false return value terminates fixed-point finding")) + (test-suite + "find-and-map/qi" + (test-syntax-map-equal? "top level" + ([(~datum b) #'q] + [_ this-syntax]) + #'(a b c) + #'(a q c)) + (test-syntax-map-equal? "does not explore node on false return value" + ([((~datum stop) e ...) #f] + [(~datum b) #'q] + [_ this-syntax]) + #'(a b (stop c b)) + #'(a q (stop c b))) + (test-syntax-map-equal? "nested" + ([(~datum b) #'q] + [_ this-syntax]) + #'(a (b c) d) + #'(a (q c) d)) + (test-syntax-map-equal? "multiple matches" + ([(~datum b) #'q] + [_ this-syntax]) + #'(a b c b d) + #'(a q c q d)) + (test-syntax-map-equal? "multiple nested matches" + ([(~datum b) #'q] + [_ this-syntax]) + #'(a (b c) (b d)) + #'(a (q c) (q d))) + (test-syntax-map-equal? "no match" + ([(~datum b) #'q] + [_ this-syntax]) + #'(a c d) + #'(a c d)) + ;; TODO: review this, it does not transform multi-level matches. + ;; See a TODO in tests/compiler/rules/normalize.rkt for a case + ;; where we would need it + (test-syntax-map-equal? "matches at multiple levels" + ([((~datum a) b ...) #'(b ...)] + [_ this-syntax]) + #'(a c (a d e)) + #'(c (a d e))) + (test-syntax-map-equal? "does not match spliced" + ([((~datum a) b ...) #'(b ...)] + [_ this-syntax]) + #'(c a b d e) + #'(c a b d e)) + (test-syntax-map-equal? "does not enter host expressions" + ([(~datum b) #'q] + [_ this-syntax]) + #'(a (#%host-expression (b c)) d) + #'(a (#%host-expression (b c)) d)) + (test-syntax-map-equal? "toplevel host expression" + ([(~datum b) #'q] + [_ this-syntax]) + #'(#%host-expression (b c)) + #'(#%host-expression (b c)))))) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/compiler/private/expand-util.rkt b/qi-test/tests/compiler/private/expand-util.rkt new file mode 100644 index 00000000..44a02b54 --- /dev/null +++ b/qi-test/tests/compiler/private/expand-util.rkt @@ -0,0 +1,24 @@ +#lang racket/base + +(provide phase0-expand-flow) + +(require (submod qi/flow/extended/expander invoke) + (for-syntax racket/base) + syntax/parse/define + syntax/macro-testing) + +;; A macro that accepts surface syntax and expands it +;; NOTE: This macro saves us the trouble of hand writing core +;; language syntax, but it also assumes that the expander is functioning +;; correctly. If there happens to be a bug in the expander, the results +;; of a compiler test depending on this macro would be invalid and may cause +;; confusion. So it's important to ensure that the tests in +;; tests/expander.rkt are comprehensive. Whenever we use this macro in +;; a test, it's worth verifying that there are corresponding tests in +;; tests/expander.rkt that validate the expansion for surface expressions +;; similar to the ones we are using in our test. +(define-syntax-parse-rule (phase0-expand-flow stx) + (phase1-eval + (expand-flow + stx) + #:quote syntax)) diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt new file mode 100644 index 00000000..873b459f --- /dev/null +++ b/qi-test/tests/compiler/rules.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(provide tests) + +(require rackunit + rackunit/text-ui + (prefix-in normalize: "rules/normalize.rkt") + (prefix-in deforest: "rules/deforest.rkt") + (prefix-in full-cycle: "rules/full-cycle.rkt")) + + +(define tests + + (test-suite + "Compiler rule tests" + + normalize:tests + deforest:tests + full-cycle:tests)) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/compiler/rules/deforest.rkt b/qi-test/tests/compiler/rules/deforest.rkt new file mode 100644 index 00000000..0184a4b7 --- /dev/null +++ b/qi-test/tests/compiler/rules/deforest.rkt @@ -0,0 +1,153 @@ +#lang racket/base + +(provide tests) + +(require (for-syntax racket/base) + "private/deforest-util.rkt" + ;; necessary to recognize and expand core forms correctly + qi/flow/extended/expander + ;; necessary to correctly expand the right-threading form + qi/flow/extended/forms + qi/flow/core/compiler + qi/flow/core/deforest + syntax/macro-testing + (submod qi/flow/extended/expander invoke) + rackunit + rackunit/text-ui + syntax/parse/define) + +;; NOTE: we need to tag test syntax with `tag-form-syntax` +;; in some cases. See the comment on that function definition. + +(define-syntax-parse-rule (test-deforested name stx) + (test-true name + (deforested? + (phase1-eval + (deforest-rewrite + (expand-flow stx)))))) + +(define-syntax-parse-rule (test-not-deforested name stx) + (test-false name + (deforested? + (phase1-eval + (deforest-rewrite + (expand-flow stx)))))) + + +(define tests + + (test-suite + "deforestation" + ;; Note that these test deforestation in isolation + ;; without necessarily taking normalization (a preceding + ;; step in compilation) into account + + (test-suite + "deforest-rewrite" + (test-suite + "general" + (test-not-deforested "does not deforest single stream component in isolation" + #'(~>> (filter odd?))) + (test-not-deforested "does not deforest map in the head position" + #'(~>> (map sqr) (filter odd?))) + (test-deforested "deforestation in arbitrary positions" + #'(~>> values + (filter odd?) + (map sqr) + values)) + (test-deforested "deforestation in arbitrary positions" + #'(~>> + values + (filter string-upcase) + (foldl string-append "I") + values))) + + (test-suite + "transformers" + (test-deforested "filter-map (two transformers)" + #'(~>> (filter odd?) (map sqr))) + (test-deforested "fine-grained template forms" + #'(~>> (filter odd? _) (map sqr _)))) + + (test-suite + "producers" + ;; TODO: note that these uses of `range` are matched as datums + ;; and requiring racket/list's range is not required in this module + ;; for deforestation to happen. This should be changed to use + ;; literal matching in the compiler. + (test-deforested "range" + #'(~>> range (filter odd?))) + (test-deforested "(range _)" + #'(~>> (range _) (filter odd?))) + (test-deforested "(range _ _)" + #'(~>> (range _ _) (filter odd?))) + (test-deforested "(range 0 _)" + #'(~>> (range 0 _) (filter odd?))) + (test-deforested "(range _ 10)" + #'(~>> (range _ 10) (filter odd?))) + (test-deforested "(range _ _ _)" + #'(~>> (range _ _ _) (filter odd?))) + (test-deforested "(range _ _ 1)" + #'(~>> (range _ _ 1) (filter odd?))) + (test-deforested "(range _ 10 _)" + #'(~>> (range _ 10 _) (filter odd?))) + (test-deforested "(range _ 10 1)" + #'(~>> (range _ 10 1) (filter odd?))) + (test-deforested "(range 0 _ _)" + #'(~>> (range 0 _ _) (filter odd?))) + (test-deforested "(range 0 _ 1)" + #'(~>> (range 0 _ 1) (filter odd?))) + (test-deforested "(range 0 10 _)" + #'(~>> (range 0 10 _) (filter odd? __))) + (test-deforested "(range __)" + #'(~>> (range __) (filter odd?))) + (test-deforested "(range 0 __)" + #'(~>> (range 0 __) (filter odd?))) + (test-deforested "(range __ 1)" + #'(~>> (range __ 1) (filter odd?))) + (test-deforested "(range 0 10 __)" + #'(~>> (range 0 10 __) (filter odd?))) + (test-deforested "(range __ 10 1)" + #'(~>> (range __ 10 1) (filter odd? __))) + (test-deforested "(range 0 __ 1)" + #'(~>> (range 0 __ 1) (filter odd?))) + (test-deforested "(range 0 10 1 __)" + #'(~>> (range 0 10 1 __) (filter odd?))) + (test-deforested "(range 0 10 __ 1)" + #'(~>> (range 0 10 __ 1) (filter odd?))) + (test-deforested "(range 0 __ 10 1)" + #'(~>> (range 0 __ 10 1) (filter odd?))) + (test-deforested "(range __ 0 10 1)" + #'(~>> (range __ 0 10 1) (filter odd?)))) + + (test-suite + "consumers" + (test-deforested "car" + #'(~>> (filter odd?) car)) + (test-deforested "foldl" + #'(~>> (filter string-upcase) (foldl string-append "I"))) + (test-deforested "foldr" + #'(~>> (filter string-upcase) (foldr string-append "I"))))) + + (test-suite + "deforest-pass" + (test-true "nested positions" + (deforested? (phase1-eval + (deforest-pass + (expand-flow + #'(>< (~>> (filter odd?) (map sqr)))))))) + (let ([stx (phase1-eval + (deforest-pass + (expand-flow + #'(-< (~>> (filter odd?) (map sqr)) + (~>> range car)))))]) + (test-true "multiple independent positions" + (deforested? stx)) + (test-true "multiple independent positions" + (filter-deforested? stx)) + (test-true "multiple independent positions" + (car-deforested? stx)))))) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/compiler/rules/full-cycle.rkt b/qi-test/tests/compiler/rules/full-cycle.rkt new file mode 100644 index 00000000..3d9ddf87 --- /dev/null +++ b/qi-test/tests/compiler/rules/full-cycle.rkt @@ -0,0 +1,47 @@ +#lang racket/base + +(provide tests) + +(require (for-syntax racket/base) + ;; necessary to recognize and expand core forms correctly + qi/flow/extended/expander + ;; necessary to correctly expand the right-threading form + qi/flow/extended/forms + rackunit + rackunit/text-ui + syntax/macro-testing + "private/deforest-util.rkt" + (submod qi/flow/extended/expander invoke)) + +(begin-for-syntax + (require syntax/parse/define + (for-template qi/flow/core/compiler) + (for-syntax racket/base)) + + ;; A macro that accepts surface syntax, expands it, and then applies the + ;; indicated optimization passes. + (define-syntax-parser test-compile~> + [(_ stx) + #'(expand-flow stx)] + [(_ stx pass ... passN) + #'(passN + (test-compile~> stx pass ...))])) + + +(define tests + + (test-suite + "full cycle tests" + + (test-suite + "multiple passes" + (test-true "normalize → deforest" + (deforested? + (phase1-eval + (test-compile~> #'(~>> (filter odd?) values (map sqr)) + normalize-pass + deforest-pass))))))) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/compiler/rules/normalize.rkt b/qi-test/tests/compiler/rules/normalize.rkt new file mode 100644 index 00000000..04722e02 --- /dev/null +++ b/qi-test/tests/compiler/rules/normalize.rkt @@ -0,0 +1,124 @@ +#lang racket/base + +(provide tests) + +(require (for-syntax racket/base) + rackunit + rackunit/text-ui + syntax/macro-testing + ;; necessary to recognize and expand core forms correctly + qi/flow/extended/expander + ;; necessary to correctly expand the right-threading form + qi/flow/extended/forms + (submod qi/flow/extended/expander invoke) + qi/flow/core/compiler + (for-template qi/flow/core/compiler) + syntax/parse/define) + +;; NOTE: we may need to tag test syntax with `tag-form-syntax` +;; in some cases. See the comment on that function definition. +;; It's not necessary if we are directly using the expander +;; output, as that already includes the property, but we might +;; need to reattach it if we tranform that syntax in some way. + +(define-syntax-parse-rule (test-normalize name a b ...+) + (begin + (test-true name + (phase1-eval + (equal? (syntax->datum + (normalize-pass + (expand-flow a))) + (syntax->datum + (normalize-pass + (expand-flow b)))))) + ...)) + + +(define tests + + (test-suite + "normalization" + + (test-suite + "equivalence of normalized expressions" + (test-normalize "pass-amp deforestation" + #'(~> + (pass f) + (>< g)) + #'(>< (if f g ground))) + (test-normalize "merge pass filters in sequence" + #'(~> (pass f) (pass g)) + #'(pass (and f g))) + (test-normalize "collapse deterministic conditionals" + #'(if #t f g) + #'f) + (test-normalize "collapse deterministic conditionals" + #'(if #f f g) + #'g) + (test-normalize "trivial threading is collapsed" + #'(~> f) + #'f) + (test-normalize "associative laws for ~>" + #'(~> f (~> g h) i) + #'(~> f g (~> h i)) + #'(~> (~> f g) h i) + #'(~> f g h i)) + (test-normalize "left and right identity for ~>" + #'(~> f _) + #'(~> _ f) + #'f) + (test-normalize "line composition of identity flows" + #'(~> _ _ _) + #'(~> _ _) + #'(~> _) + #'_) + (test-normalize "amp under identity" + #'(>< _) + #'_) + (test-normalize "trivial tee junction" + #'(-< f) + #'f) + (test-normalize "merge adjacent gens in a tee junction" + #'(-< (gen a b) (gen c d)) + #'(-< (gen a b c d))) + (test-normalize "remove dead gen in a line" + #'(~> (gen a b) (gen c d)) + #'(~> (gen c d))) + (test-normalize "prism identities" + #'(~> ▽ △) + #'_) + (test-normalize "redundant blanket template" + #'(f __) + #'f) + (test-normalize "values is collapsed inside ~>" + #'(~> values f values) + #'(~> f)) + ;; TODO: this test reveals a case that should be + ;; rewritten but isn't. Currently, once there is a + ;; match at one level during tree traversal + ;; (in find-and-map), we do not traverse the expression + ;; further. + ;; (test-normalize "multiple levels of normalization" + ;; #'(~> (>< (~> f))) + ;; #'(>< f)) + (test-normalize "_ is collapsed inside ~>" + #'(~> _ f _) + #'f) + (test-normalize "nested positions" + #'(>< (>< (~> _ f _))) + #'(>< (>< f))) + (test-normalize "multiple independent positions" + #'(-< (~> _ f _) (~> (~> f g))) + #'(-< f (~> f g)))) + + (test-suite + "specific output" + (test-equal? "weird bug" + (syntax->datum + (normalize-pass #'(thread tee collect))) + (syntax->datum + #'(thread tee collect)))))) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/compiler/rules/private/deforest-util.rkt b/qi-test/tests/compiler/rules/private/deforest-util.rkt new file mode 100644 index 00000000..193a986d --- /dev/null +++ b/qi-test/tests/compiler/rules/private/deforest-util.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(provide deforested? + filter-deforested? + car-deforested?) + +;; Note: an alternative way to make these assertions could be to add logging +;; to compiler passes to trace what happens to a source expression, capturing +;; those logs in these tests and verifying that the logs indicate the expected +;; passes were performed. Such logs would also allow us to validate that +;; passes were performed in the expected order, at some point in the future +;; when we might have nonlinear ordering of passes. See the Qi meeting notes: +;; "Validly Verifying that We're Compiling Correctly" +(require racket/string) + +(define (deforested? exp) + (string-contains? (format "~a" exp) "cstream")) + +(define (filter-deforested? exp) + (string-contains? (format "~a" exp) "filter-cstream")) + +(define (car-deforested? exp) + (string-contains? (format "~a" exp) "car-cstream")) diff --git a/qi-test/tests/compiler/semantics.rkt b/qi-test/tests/compiler/semantics.rkt new file mode 100644 index 00000000..ea3ceecc --- /dev/null +++ b/qi-test/tests/compiler/semantics.rkt @@ -0,0 +1,189 @@ +#lang racket/base + +(provide tests) + +(require qi + rackunit + rackunit/text-ui + (only-in math sqr) + (only-in racket/list range) + syntax/macro-testing + racket/function) + +(define tests + (test-suite + "Compiler preserves semantics" + + (test-suite + "deforestation" + + (test-suite + "general" + (check-equal? ((☯ (~>> (filter odd?) (map sqr))) + (list 1 2 3 4 5)) + (list 1 9 25)) + (check-exn exn:fail? + (thunk + ((☯ (~> (map sqr) (map sqr))) + (list 1 2 3 4 5))) + "(map) doforestation should only be done for right threading") + (check-exn exn:fail? + (thunk + ((☯ (~> (filter odd?) (filter odd?))) + (list 1 2 3 4 5))) + "(filter) doforestation should only be done for right threading") + (check-exn exn:fail? + (thunk + ((☯ (~>> (filter odd?) (~> (foldr + 0)))) + (list 1 2 3 4 5))) + "(foldr) doforestation should only be done for right threading") + (check-equal? ((☯ (~>> values (filter odd?) (map sqr) values)) + (list 1 2 3 4 5)) + (list 1 9 25) + "optimizes subexpressions") + (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldr + 0))) + (list 1 2 3 4 5)) + 35) + (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldl + 0))) + (list 1 2 3 4 5)) + 35) + (check-equal? ((☯ (~>> (map string-upcase) (foldr string-append "I"))) + (list "a" "b" "c")) + "ABCI") + (check-equal? ((☯ (~>> (map string-upcase) (foldl string-append "I"))) + (list "a" "b" "c")) + "CBAI") + (check-equal? ((☯ (~>> (range 10) (map sqr) car))) + 0)) + + (test-suite + "error reporting" + (test-exn "deforestation syntax phase - too many arguments for range producer (blanket)" + exn? + (lambda () + (convert-compile-time-error + ((flow (~>> (range 1 2 3 4 5) (filter odd?) (map sqr))))))) + + (test-exn "deforestation syntax phase - too many arguments for range producer (fine)" + exn? + (lambda () + (convert-compile-time-error + ((flow (~>> (range 1 2 3 4 5 _) (filter odd?) (map sqr))))))) + + (test-equal? "deforestation list->cstream-next usage" + ((flow (~>> (filter odd?) (map sqr))) + '(0 1 2 3 4 5 6 7 8 9)) + '(1 9 25 49 81)) + + (test-exn "deforestation range->cstream-next - too few arguments at runtime" + exn? + (lambda () + ((flow (~>> range (filter odd?) (map sqr)))))) + + (test-exn "deforestation range->cstream-next - too many arguments at runtime" + exn? + (lambda () + ((flow (~>> range (filter odd?) (map sqr))) 1 2 3 4))) + + (test-exn "deforestation car-cstream-next - empty list" + exn? + (lambda () + ((flow (~>> (filter odd?) (map sqr) car)) '())))) + + (test-suite + "range (stream producer)" + ;; Semantic tests of the range producer that cover all combinations: + (test-equal? "~>>range [1-3] (10)" + (~>> (10) range (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>range [1-3] (10)" + (~> (10) range (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> range [1-3] (5 10)" + (~>> (5 10) range (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> range [1-3] (5 10)" + (~> (5 10) range (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> range [1-3] (5 10 3)" + (~>> (5 10 3) range (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> range [1-3] (5 10 3)" + (~> (5 10 3) range (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 10) [0-2] ()" + (~>> () (range 10) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~> (range 10) [0-2] ()" + (~> () (range 10) (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> (range 5) [0-2] (10)" + (~>> (10) (range 5) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 10) [0-2] (5)" + (~> (5) (range 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 3) [0-2] (5 10)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 5) [0-2] (10 3)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 5 10) [0-1] ()" + (~>> () (range 5 10) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 5 10) [0-1] ()" + (~> () (range 5 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 5 10) [0-1] (3)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 10 3) [0-1] (5)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 5 10 3) [0] ()" + (~>> () (range 5 10 3) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range _) [1] (10)" + (~>> (10) (range _) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>> (range _ _) [2] (5 10)" + (~>> (5 10) (range _ _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ _ _) [3] (5 10 3)" + (~>> (5 10 3) (range _ _ _) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range 5 _) [1] (10)" + (~>> (10) (range 5 _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ 10) [1] (5)" + (~>> (5) (range _ 10) (filter odd?) (map sqr)) + '(25 49 81)) + + (test-equal? "~>> (range 5 _ _) [2] (10 3)" + (~>> (10 3) (range 5 _ _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 _) [2] (5 3)" + (~>> (5 3) (range _ 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ _ 3) [2] (5 10)" + (~>> (5 10) (range _ _ 3) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range 5 10 _) [1] (3)" + (~>> (3) (range 5 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range 5 _ 3) [1] (10)" + (~>> (10) (range 5 _ 3) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 3) [1] (5)" + (~>> (5) (range _ 10 3) (filter odd?) (map sqr)) + '(25)))))) + +(module+ main + (void (run-tests tests))) diff --git a/qi-test/tests/expander.rkt b/qi-test/tests/expander.rkt new file mode 100644 index 00000000..07e55692 --- /dev/null +++ b/qi-test/tests/expander.rkt @@ -0,0 +1,181 @@ +#lang racket/base + +(provide tests) + +(require (for-syntax racket/base + qi/flow/extended/syntax) + (submod qi/flow/extended/expander invoke) + syntax/macro-testing + racket/base + ;; necessary to recognize and expand core forms correctly + qi/flow/extended/expander + ;; necessary to correctly expand the right-threading form + qi/flow/extended/forms + syntax/parse/define + qi/flow/extended/util + rackunit + rackunit/text-ui) + +(define-syntax-parse-rule (test-expand name source target) + (test-true name + (phase1-eval + (equal? (syntax->datum + (expand-flow source)) + (syntax->datum target))))) + +;; TODO: these tests compare syntax as datums, but that's not sufficient +;; since the identifiers used may be bound differently which would affect +;; e.g. literal pattern matching. +;; To do it correctly, we need an alpha-equivalence predicate for Core Qi +;; that possibly delegates to a similar predicate for any Racket +;; subexpressions. This could be a predicate that syntax-spec could +;; infer, but it's unclear at this time. +(define tests + (test-suite + "expander tests" + + (test-suite + "rules" + (test-expand "basic expansion" + #'(~> sqr add1) + #'(thread (esc (#%host-expression sqr)) + (esc (#%host-expression add1)))) + + (test-expand "if" + #'(if p c a) + #'(if (esc (#%host-expression p)) + (esc (#%host-expression c)) + (esc (#%host-expression a)))) + + (test-expand "amp" + #'(>< f) + #'(amp (esc (#%host-expression f)))) + + (test-expand "tee" + #'(-< f g) + #'(tee (esc (#%host-expression f)) + (esc (#%host-expression g)))) + + (test-expand "mix of core forms" + #'(thread (amp a) + (relay b c) + (tee d e)) + #'(thread + (amp (esc (#%host-expression a))) + (relay (esc (#%host-expression b)) (esc (#%host-expression c))) + (tee (esc (#%host-expression d)) (esc (#%host-expression e))))) + + (test-expand "undecorated identifiers are escaped" + #'f + #'(esc (#%host-expression f))) + + (test-expand "literal is expanded to an explicit use of the gen core form" + #'5 + #'(gen (#%host-expression 5))) + + (test-expand "fine template syntax expands to an explicit use of the #%fine-template core form" + #'(f _ a _ b) + #'(#%fine-template + ((#%host-expression f) + _ + (#%host-expression a) + _ + (#%host-expression b)))) + + (test-expand "blanket template syntax expands to an explicit use of the #%blanket-template core form" + #'(f a __ b) + #'(#%blanket-template + ((#%host-expression f) + (#%host-expression a) + __ + (#%host-expression b)))) + + (test-expand "partial application expands to a blanket template" + #'(f a b) + #'(#%blanket-template + ((#%host-expression f) + __ + (#%host-expression a) + (#%host-expression b)))) + + (test-expand "expand chiral forms to a use of a blanket template" + #'(~>> (f 1)) + #'(thread (#%blanket-template + ((#%host-expression f) + (#%host-expression 1) + __))))) + (test-suite + "utils" + ;; this is just temporary until we properly track source expressions through + ;; expansion, so it doesn't match all the nuances of the core language grammar + (test-equal? "de-expansion" + (syntax->datum + (datum->syntax #f + (map prettify-flow-syntax + '(flow (gen (#%host-expression f)) + ground + (select 1 2) + (amp (esc (#%host-expression f))) + (relay (esc (#%host-expression f)) (esc (#%host-expression g))) + (tee (esc (#%host-expression f)) (esc (#%host-expression g))) + (thread (esc (#%host-expression f)) (esc (#%host-expression g))) + (gen (#%host-expression 2) (#%host-expression 3)) + (pass (esc (#%host-expression f))) + (sep (esc (#%host-expression g))) + (and (esc (#%host-expression f)) (or (esc (#%host-expression g)) (not (esc (#%host-expression h))))) + (all (esc (#%host-expression f))) + (any (esc (#%host-expression f))) + (fanout (#%host-expression 2)) + (group (#%host-expression a) (esc (#%host-expression b)) (esc (#%host-expression c))) + (if (esc (#%host-expression a)) (esc (#%host-expression f))) + (sieve (esc (#%host-expression a)) (esc (#%host-expression b)) (esc (#%host-expression c))) + (partition ((esc (#%host-expression a)) (esc (#%host-expression b))) + ((esc (#%host-expression c)) (esc (#%host-expression d)))) + (try (esc (#%host-expression q)) + ((esc (#%host-expression a)) (esc (#%host-expression b))) + ((esc (#%host-expression c)) (esc (#%host-expression d)))) + (>> (esc (#%host-expression f))) + (<< (esc (#%host-expression f))) + (feedback (while (esc (#%host-expression f)))) + (loop (esc (#%host-expression f))) + (loop2 (esc (#%host-expression f)) (esc (#%host-expression a)) (esc (#%host-expression f))) + (clos (esc (#%host-expression f))) + (esc (#%host-expression f)) + (#%blanket-template ((#%host-expression 1) __ (#%host-expression 4))) + (#%blanket-template ((#%host-expression 4) __)) + (#%fine-template ((#%host-expression 4) _)))))) + '(flow (gen f) + ground + (select 1 2) + (>< f) + (== f g) + (-< f g) + (~> f g) + (gen 2 3) + (pass f) + (sep g) + (and f (or g (not h))) + (all f) + (any f) + (fanout 2) + (group a b c) + (if a f) + (sieve a b c) + ;; partition and try are actually jumbled + (partition (a b) (c d)) + (try q (a b) (c d)) + (>> f) + (<< f) + ;; feedback grammar not handled - it's just a hack anyway + (feedback (while (esc (#%host-expression f)))) + (loop f) + (loop2 f a f) + (clos f) + f + (1 __ 4) + (4 __) + (4 _)))))) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index d6128042..df8e59c2 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -10,7 +10,10 @@ racket/list racket/string racket/function - "private/util.rkt") + racket/format + (except-in "private/util.rkt" + add-two) + syntax/macro-testing) ;; used in the "language extension" tests for `qi:*` (define-syntax-rule (qi:square flo) @@ -26,14 +29,29 @@ (test-suite "core language" + (test-suite + "Syntax" + (check-exn exn:fail? + (thunk (convert-compile-time-error + (☯ 1 2))) + "flow expects exactly one argument")) (test-suite "Edge/base cases" (check-equal? (values->list ((☯))) null "empty flow with no inputs") (check-equal? ((☯) 0) 0 "empty flow with one input") (check-equal? (values->list ((☯) 1 2)) (list 1 2) "empty flow with multiple inputs") - (check-equal? ((☯ (const 3))) 3 "no arguments") + (check-equal? ((☯ (+ 3))) 3 "partial application with no runtime arguments") (check-equal? ((flow add1) 2) 3 "simple function") - (check-equal? ((flow (get-f 1)) 2) 3 "fully qualified function") + (check-exn exn:fail:contract? + (thunk ((flow (get-f 1)) 2)) + "fully qualified function is still treated as a partial application") + ;; As this is a syntax error, it can't be written as a unit test + ;; (check-exn exn:fail:contract? + ;; (thunk (flow (get-f))) + ;; "empty partial application isn't allowed") + (check-equal? ((flow (esc (get-f 1))) 2) + 3 + "fully qualified function used as a flow must still use esc") (check-equal? ((flow _) 5) 5 "identity flow") (check-equal? ((flow (~> _ ▽)) 5 6) (list 5 6) "identity flow")) (test-suite @@ -44,10 +62,17 @@ (check-equal? ((flow #"hi") 5) #"hi" "literal byte string") (check-equal? ((flow #px"hi") 5) #px"hi" "literal regexp") (check-equal? ((flow #rx"hi") 5) #rx"hi" "literal regexp") + (check-equal? ((flow #px#"hi") 5) #px#"hi" "bytestring literal regexp") + (check-equal? ((flow #rx#"hi") 5) #rx#"hi" "bytestring literal regexp") (check-equal? ((flow 'hi) 5) 'hi "literal symbol") + (check-equal? ((flow #(1 2 3)) 2) #(1 2 3) "literal vector") + (check-equal? ((flow #&3) 2) #&3 "literal box") + (check-equal? ((flow #&(1 2 3)) 2) #&(1 2 3) "literal collection in a box") + (check-equal? ((flow #s(dog "Fido")) 2) #s(dog "Fido") "literal prefab") (check-equal? ((flow '(+ 1 2)) 5) '(+ 1 2) "literal quoted list") (check-equal? ((flow `(+ 1 ,(* 2 3))) 5) '(+ 1 6) "literal quasiquoted list") - (check-equal? (syntax->datum ((flow #'(+ 1 2)) 5)) '(+ 1 2) "Literal syntax quoted list")) + (check-equal? (syntax->datum ((flow #'abc) 5)) 'abc "Literal syntax") + (check-equal? (syntax->datum ((flow (quote-syntax (+ 1 2))) 5)) '(+ 1 2) "Literal syntax quoted list")) (test-suite "unary predicate" (check-false ((☯ negative?) 5)) @@ -109,7 +134,7 @@ (check-true ((☯ (and positive? (or integer? odd?))) - 5)) + 5)) (check-false ((☯ (and positive? (or (> 6) even?))) @@ -183,19 +208,19 @@ (test-suite "all?" (check-true ((☯ all?)) "design: should this produce no values instead?") - (check-true ((☯ all?) 3)) - (check-false ((☯ all?) #f)) - (check-true ((☯ all?) 3 5 7)) - (check-false ((☯ all?) 3 #f 5))) + (check-equal? ((☯ all?) 3) 3) + (check-equal? ((☯ all?) #f) #f) + (check-equal? ((☯ all?) 3 5 7) 7) + (check-equal? ((☯ all?) 3 #f 5) #f)) (test-suite "any?" (check-false ((☯ any?)) "design: should this produce no values instead?") - (check-true ((☯ any?) 3)) - (check-false ((☯ any?) #f)) - (check-true ((☯ any?) 3 5 7)) - (check-true ((☯ any?) 3 #f 5)) - (check-true ((☯ any?) #f #f 5)) - (check-false ((☯ any?) #f #f #f))) + (check-equal? ((☯ any?) 3) 3) + (check-equal? ((☯ any?) #f) #f) + (check-equal? ((☯ any?) 3 5 7) 3) + (check-equal? ((☯ any?) 3 #f 5) 3) + (check-equal? ((☯ any?) #f #f 5) 5) + (check-equal? ((☯ any?) #f #f #f) #f)) (test-suite "none?" (check-false ((☯ none?) 3)) @@ -254,6 +279,8 @@ (list 3 4 5))) (test-suite "escape hatch" + (check-equal? ((☯ (esc add1)) 2) 3) + (check-equal? ((☯ (esc (const 3)))) 3) (check-equal? ((☯ (esc (first (list + *)))) 3 7) 10 "normal racket expressions")) @@ -261,20 +288,20 @@ "elementary boolean gates" (test-suite "AND" - (check-false ((☯ AND) #f)) - (check-true ((☯ AND) 3)) - (check-true ((☯ AND) 3 5 7)) - (check-false ((☯ AND) 3 #f 5)) - (check-false ((☯ AND) #f #f 5)) - (check-false ((☯ AND) #f #f #f))) + (check-equal? ((☯ AND) #f) #f) + (check-equal? ((☯ AND) 3) 3) + (check-equal? ((☯ AND) 3 5 7) 7) + (check-equal? ((☯ AND) 3 #f 5) #f) + (check-equal? ((☯ AND) #f #f 5) #f) + (check-equal? ((☯ AND) #f #f #f) #f)) (test-suite "OR" - (check-false ((☯ OR) #f)) - (check-true ((☯ OR) 3)) - (check-true ((☯ OR) 3 5 7)) - (check-true ((☯ OR) 3 #f 5)) - (check-true ((☯ OR) #f #f 5)) - (check-false ((☯ OR) #f #f #f))) + (check-equal? ((☯ OR) #f) #f) + (check-equal? ((☯ OR) 3) 3) + (check-equal? ((☯ OR) 3 5 7) 3) + (check-equal? ((☯ OR) 3 #f 5) 3) + (check-equal? ((☯ OR) #f #f 5) 5) + (check-equal? ((☯ OR) #f #f #f) #f)) (test-suite "NOT" (check-false ((☯ NOT) 3)) @@ -329,10 +356,118 @@ (check-equal? ((☯ (~> ▽ △ string-append)) "a" "b" "c") "abc")))) + (test-suite + "bindings" + (check-equal? ((☯ (~> (as v) (+ v))) 3) + 3 + "binds a single value") + (check-equal? ((☯ (~> (as v w) (+ v w))) 3 4) + 7 + "binds multiple values") + (check-false ((☯ (~> (as v) live?)) 3) + "binding does not propagate the value") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 _ v))) 3) + 9 + "reference in a fine template") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 __ v))) 3) + 9 + "reference in a blanket template") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 v))) 3) + 9 + "reference in a left-chiral partial application") + (check-equal? ((☯ (~>> (-< (as v) + _) (+ 3 v))) 3) + 9 + "reference in a right-chiral partial application") + (check-equal? ((☯ (~> (-< (~> list (as vs)) + +) + (~a "The sum of " vs " is " _))) + 1 2) + "The sum of (1 2) is 3" + "bindings are scoped to the outermost threading form") + (check-equal? ((☯ (~> (-< sqr (~> list (as S))) + (-< add1 (~>> list (append S) (as S))) + (-< _ (~>> list (append S) (as S))) + (list S))) + 5) + (list 26 (list 5 25 26)) + "binding to accumulate state") + (check-equal? ((☯ (~> (ε (as args)) (append args))) + (list 1 2 3)) + (list 1 2 3 1 2 3) + "idiom: bind as a side effect") + (check-equal? ((☯ (~> (as n) 5 (feedback n add1))) + 3) + 8 + "using a bound value in a flow specification") + (check-equal? ((☯ (~> (== (as n) _) sqr (+ n))) + 3 5) + 28 + "binding some but not all values using a relay") + (check-equal? (map (☯ (~> (as n) (+ n n))) + (list 1 3 5)) + (list 2 6 10) + "binding arguments without a lambda") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> sqr (list v) (as v) (gen v))) 3))) + "bindings cannot be referenced before being assigned") + (check-equal? ((☯ (~> (-< (as v) + (gen v)))) + 3) + 3 + "tee junction tines bind succeeding peers") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> (-< (gen v) + (as v)))) + 3))) + "tee junction tines don't bind preceding peers") + (check-equal? ((☯ (switch [(~> sqr (ε (as v) #t)) + (gen v)])) + 3) + 9 + "switch conditions bind clauses") + (check-equal? ((☯ (switch + [(~> sqr (ε (as v) #f)) + (gen v)] + [(~> add1 (ε (as v) #t)) + (gen v)])) + 3) + 4 + "bindings in switch conditions shadow earlier conditions") + (check-exn exn:fail? + (thunk + (convert-compile-time-error + ((☯ (~> (switch [(~> sqr (ε (as v) #t)) + 0]) + (gen v))) + 3))) + "switch does not bind downstream") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> (or (ε (as v)) 5) (+ v))) + 3))) + "error is raised if identifier is not guaranteed to be bound downstream") + (let ([as (lambda (v) v)]) + (check-equal? ((☯ (~> (gen (as 3))))) + 3 + "Racket functions named `as` aren't clobbered") + (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) + 3 + "Racket functions named `as` aren't clobbered"))) + (test-suite "routing forms" (test-suite "~>" + (test-equal? "basic threading" + ((☯ (~> sqr add1)) + 3) + 10) (check-equal? ((☯ (~> add1 (* 2) number->string @@ -362,6 +497,10 @@ "p" "q") "pabqab" "threading without template") + (check-equal? ((☯ (~> (sort 3 1 2 #:key sqr))) + <) + (list 1 4 9) + "pre-supplied keyword arguments with left chirality") (check-equal? ((☯ (thread add1 (* 2) number->string @@ -395,14 +534,10 @@ "p" "q") "abpq" "right-threading without template") - (check-equal? ((☯ (~>> △ (sort < #:key identity))) + (check-equal? ((☯ (~>> △ (sort < #:key sqr))) (list 2 1 3)) - (list 1 2 3) - "right-threading with keyword arg pre-supplied") - (check-equal? ((☯ (~>> (sort <))) - #:key identity 2 1 3) - (list 1 2 3) - "right-threading with keyword arg at invocation time") + (list 1 4 9) + "pre-supplied keyword arguments with right chirality") ;; TODO: propagate threading side to nested clauses ;; (check-equal? (on ("p" "q") ;; (~>> (>< (string-append "a" "b")) @@ -428,6 +563,9 @@ "a")) (test-suite "-<" + (check-equal? ((☯ (~> -< ▽)) + 3 1 2) + (list 1 2 1 2 1 2)) (check-equal? ((☯ (~> (-< sqr add1) ▽)) 5) (list 25 6)) @@ -488,6 +626,9 @@ (thunk ((☯ (~> (== ⏚ add1) ▽)) 5 7 8)) "relay elements must be in one-to-one correspondence with input") + (check-equal? ((☯ (~> (gen sqr 1 2 3) == ▽))) + (list 1 4 9) + "relay when used as an identifier") ; TODO: review this (check-equal? ((☯ (~> (relay sqr add1) ▽)) 5 7) (list 25 8) @@ -524,7 +665,11 @@ (check-equal? ((☯ (try (/ 0) [exn:fail:contract:arity? 'arity] [exn:fail:contract:divide-by-zero? 'divide-by-zero])) 9) - 'divide-by-zero)) + 'divide-by-zero) + (check-exn exn:fail? + (thunk (convert-compile-time-error + (☯ (try 1 2)))) + "invalid try syntax")) (test-suite "partial application" @@ -578,10 +723,13 @@ (list "a" "b" "c")) "cba" "curried foldl") - (check-exn exn:fail? - (thunk ((☯ (+)) - 5 7 8)) - "function isn't curried when no arguments are provided")) + (check-equal? (((☯ (const 3)))) 3 "partial application with no arguments") + ;; As this is now a syntax error, it can't be written as a unit test + ;; (check-exn exn:fail? + ;; (thunk ((☯ (+)) + ;; 5 7 8)) + ;; "function isn't curried when no arguments are provided") + ) (test-suite "blanket template" (check-equal? ((☯ (+ __))) 0) @@ -593,9 +741,21 @@ "abc") (check-equal? ((☯ (string-append __ "c")) "a" "b") - "abc")) - (test-suite - "template with single argument" + "abc") + (check-equal? ((☯ (sort __ 1 2 #:key sqr)) + < 3) + (list 1 4 9) + "keyword arguments in a left chiral blanket template") + (check-equal? ((☯ (sort < 3 #:key sqr __)) + 1 2) + (list 1 4 9) + "keyword arguments in a right chiral blanket template") + (check-equal? ((☯ (sort < __ #:key sqr)) + 3 1 2) + (list 1 4 9) + "keyword arguments in a vindaloo blanket template")) + (test-suite + "fine template with single argument" (check-false ((☯ (apply > _)) (list 1 2 3))) (check-true ((☯ (apply > _)) @@ -614,21 +774,26 @@ (check-equal? ((☯ (foldl string-append "" _)) (list "a" "b" "c")) "cba" - "foldl in predicate")) + "foldl in predicate") + (check-equal? ((☯ (sort < 3 _ 2 #:key sqr)) + 1) + (list 1 4 9) + "keyword arguments in a fine template")) (test-suite - "template with multiple arguments" + "fine template with multiple arguments" (check-true ((☯ (< 1 _ 5 _ 10)) 3 7) "template with multiple arguments") (check-false ((☯ (< 1 _ 5 _ 10)) 3 5) - "template with multiple arguments")) + "template with multiple arguments") + (check-equal? ((☯ (sort < _ _ 2 #:key sqr)) + 3 1) + (list 1 4 9) + "keyword arguments in a fine template")) (test-suite "templating behavior is contained to intentional template syntax" (check-exn exn:fail:syntax? - (thunk (parameterize ([current-namespace (make-base-empty-namespace)]) - (namespace-require 'racket/base) - (namespace-require 'qi) - (eval '(☯ (feedback _ add1)) - (current-namespace)))) + (thunk (convert-compile-time-error + (☯ (feedback _ add1)))) "invalid syntax accepted on the basis of an assumed fancy-app template"))) (test-suite @@ -806,6 +971,11 @@ [else 'hi])) 2) 2) + (check-equal? ((☯ (switch + [(member (list 1 5 4 2 6)) (=> 1>)] + [else 'hi])) + 10) + 'hi) (check-equal? ((☯ (switch [car (=> (== _ 5) apply)] [else 'hi])) @@ -830,13 +1000,13 @@ "short-circuiting")) (test-suite "sieve" - (check-equal? ((☯ (~> (sieve positive? add1 (const -1)) ▽)) + (check-equal? ((☯ (~> (sieve positive? add1 (gen -1)) ▽)) 1 -2) (list 2 -1)) (check-equal? ((☯ (~> (sieve positive? + (+ 2)) ▽)) 1 2 -3 4) (list 7 -1)) - (check-equal? ((☯ (~> (sieve positive? + (const 0)) ▽)) + (check-equal? ((☯ (~> (sieve positive? + (gen 0)) ▽)) 1 2 3 4) (list 10 0)) (check-equal? ((☯ (~> (sieve negative? ⏚ ⏚) ▽)) @@ -851,37 +1021,60 @@ 1 -3 5) (list 1 1 5 5 -3) "sieve with arity-increasing clause") - (check-equal? (~> (1 2 -3 4) - (-< (gen positive? + (☯ (+ 2))) _) - sieve - ▽) + (check-equal? ((☯ (~> (-< (gen positive? + (☯ (+ 2))) _) + sieve + ▽)) + 1 2 -3 4) (list 7 -1) - "pure control form of sieve")) - (test-suite - "partition" - (check-equal? ((flow (~> (partition) collect))) - (list) - "base partition case") - (check-equal? ((flow (partition [positive? +])) - -1 2 1 1 -2 2) - 6 - "partition composes ~> and pass") - (check-equal? ((flow (~> (partition [positive? +] - [zero? (-< count (gen "zero"))] - [negative? *]) collect)) - -1 0 2 1 1 -2 0 0 2) - (list 6 3 "zero" 2)) - (check-equal? ((flow (~> (partition [positive? +] - [zero? (-< count (gen "zero"))] - [negative? *]) collect)) - -1 2 1 1 -2 2) - (list 6 0 "zero" 2) - "some partition bodies have no inputs") - (check-equal? ((flow (~> (partition [(and positive? (> 1)) +] - [_ list]) collect)) - -1 2 1 1 -2 2) - (list 4 (list -1 1 1 -2)) - "partition bodies can be flows")) + "pure control form of sieve") + (check-exn exn:fail? + (thunk (convert-compile-time-error + (☯ (sieve 1 2)))) + "invalid sieve syntax")) + (test-suite + "partition" + (check-equal? ((flow (~> (partition) collect))) + (list) + "base partition case") + (check-equal? ((flow (partition [positive? +])) + -1 2 1 1 -2 2) + 6 + "partition composes ~> and pass") + (check-equal? ((flow (~> (partition [positive? +] + [zero? (-< count (gen "zero"))] + [negative? *]) collect)) + -1 0 2 1 1 -2 0 0 2) + (list 6 3 "zero" 2)) + (check-equal? ((flow (~> (partition [positive? +] + [zero? (-< count (gen "zero"))] + [negative? *]) collect)) + -1 2 1 1 -2 2) + (list 6 0 "zero" 2) + "some partition bodies have no inputs") + (check-equal? ((flow (~> (partition [(and positive? (> 1)) +] + [_ list]) collect)) + -1 2 1 1 -2 2) + (list 4 (list -1 1 1 -2)) + "partition bodies can be flows") + (check-equal? ((flow (~> (partition [#f list] + [(and positive? (> 1)) +]) collect)) + -1 2 1 1 -2 2) + (list null 4) + "no match in first clause") + (check-equal? ((flow (~> (partition [(and positive? (> 1)) +] + [#f list]) collect)) + -1 2 1 1 -2 2) + (list 4 null) + "no match in last clause") + (check-equal? ((flow (~> (partition [#f list] + [#f list]) collect)) + -1 2 1 1 -2 2) + (list null null) + "no match in any clause") + (check-not-exn (thunk + (convert-compile-time-error + (☯ (partition [-< ▽])))) + "no improper optimization of subforms resembling use of core syntax")) (test-suite "gate" (check-equal? ((☯ (gate positive?)) @@ -927,31 +1120,32 @@ 9)) (test-suite "fanout" - (check-equal? (~> (5) (fanout 3) ▽) + (check-equal? ((☯ (~> (fanout 3) ▽)) + 5) (list 5 5 5)) - (check-equal? (~> (2 3) (fanout 3) ▽) + (check-equal? ((☯ (~> (fanout 3) ▽)) 2 3) (list 2 3 2 3 2 3)) - (check-equal? (~> (3 "a") fanout string-append) + (check-equal? ((☯ (~> fanout string-append)) 3 "a") "aaa" "control form of fanout") - (check-equal? (~> (3 "a" "b") fanout string-append) + (check-equal? ((☯ (~> fanout string-append)) 3 "a" "b") "ababab" "control form of fanout") - (check-equal? (~> (5) (fanout (add1 2)) ▽) + (check-equal? ((☯ (~> (fanout (add1 2)) ▽)) 5) (list 5 5 5) "arbitrary racket expressions and not just literals") (check-equal? (let ([n 3]) - (~> (5) (fanout n) ▽)) + ((☯ (~> (fanout n) ▽)) 5)) (list 5 5 5) "arbitrary racket expressions and not just literals") - (check-equal? (~> (2 3) (fanout 0) ▽) + (check-equal? ((☯ (~> (fanout 0) ▽)) 2 3) null "N=0 produces no values.") - (check-equal? (~> () (fanout 3) ▽) + (check-equal? ((☯ (~> (fanout 3) ▽))) null "No inputs produces no outputs.") (check-exn exn:fail:contract? - (thunk (~> (-1 3) fanout ▽)) + (thunk ((☯ (~> fanout ▽)) -1 3)) "Negative N signals an error.")) (test-suite "inverter" @@ -967,7 +1161,7 @@ 5) 625 "(feedback N flo)") - (check-equal? (~> (3 5) (feedback add1)) + (check-equal? ((☯ (~> (feedback add1))) 3 5) 8 "(feedback flo) consumes the first input as N") (check-equal? ((☯ (feedback 5 (then sqr) add1)) @@ -1011,7 +1205,7 @@ "pure control form of feedback")) (test-suite "group" - (check-equal? ((☯ (~> (group 0 (const 5) +) ▽)) + (check-equal? ((☯ (~> (group 0 (gen 5) +) ▽)) 1 2) (list 5 3)) (check-equal? ((☯ (~> (group 1 add1 sub1) ▽)) @@ -1056,7 +1250,11 @@ (thunk ((☯ (~> (group 3 _ ⏚) ▽)) 1 3)) - "grouping more inputs than are available shows a helpful error")) + "grouping more inputs than are available shows a helpful error") + (check-exn exn:fail? + (thunk (convert-compile-time-error + (☯ (group 1 2)))) + "invalid group syntax")) (test-suite "select" (check-equal? ((☯ (~> (select) ▽)) @@ -1086,7 +1284,11 @@ (check-exn exn:fail? (thunk ((☯ (select 0)) 1 3)) - "attempting to select index 0 (select is 1-indexed)")) + "attempting to select index 0 (select is 1-indexed)") + (check-exn exn:fail? + (thunk (convert-compile-time-error + (☯ (select (+ 1 1))))) + "select expects literal numbers")) (test-suite "block" (check-equal? ((☯ (~> (block) list)) @@ -1114,7 +1316,11 @@ (check-exn exn:fail? (thunk ((☯ (block 0)) 1 3)) - "attempting to block index 0 (block is 1-indexed)")) + "attempting to block index 0 (block is 1-indexed)") + (check-exn exn:fail? + (thunk (convert-compile-time-error + (☯ (block (+ 1 1))))) + "block expects literal numbers")) (test-suite "bundle" (check-equal? ((☯ (~> (bundle () + sqr) ▽)) @@ -1165,16 +1371,16 @@ (check-true ((☯ live?) 3 4 5)) (check-true ((☯ live?) 5)) (check-false ((☯ live?))) - (check-true (~> (1 2) live?)) - (check-false (~> (1 2) ⏚ live?))) + (check-true ((☯ (~> live?)) 1 2)) + (check-false ((☯ (~> ⏚ live?)) 1 2))) (test-suite "rectify" - (check-equal? (~> (3 4 5) (rectify 'boo) ▽) (list 3 4 5)) - (check-equal? (~> (5) (rectify 'boo)) 5) - (check-equal? (~> () (rectify 'boo)) 'boo) - (check-equal? (~> (1 2) (rectify #f) ▽) (list 1 2)) - (check-equal? (~> (1 2) ⏚ (rectify #f)) #f))) + (check-equal? ((☯ (~> (rectify 'boo) ▽)) 3 4 5) (list 3 4 5)) + (check-equal? ((☯ (~> (rectify 'boo))) 5) 5) + (check-equal? ((☯ (~> (rectify 'boo)))) 'boo) + (check-equal? ((☯ (~> (rectify #f) ▽)) 1 2) (list 1 2)) + (check-equal? ((☯ (~> ⏚ (rectify #f))) 1 2) #f))) (test-suite "higher-order flows" @@ -1201,7 +1407,11 @@ (check-equal? ((☯ (~> (amp sqr) ▽)) 3 5) (list 9 25) - "named amplification form")) + "named amplification form") + (check-exn exn:fail? + (thunk (convert-compile-time-error + (☯ (>< sqr add1)))) + "amp expects exactly one argument")) (test-suite "pass" (check-equal? ((☯ (~> pass ▽)) @@ -1253,28 +1463,43 @@ sqr) ▽)) 1 2 3) (list 1 4 9)) - (check-equal? ((☯ (~> (loop (~> ▽ (not null?)) - sqr - + - 0))) 1 2 3) + (check-equal? ((☯ (loop (~> ▽ (not null?)) + sqr + + + 0)) 1 2 3) 14) + (check-equal? ((☯ (loop (~> ▽ (not null?)) + (-< sqr sqr) + + + 0)) 1 2 3) + 28 + "loop with multi-valued map flow") (check-equal? ((☯ (~> (loop sqr) ▽)) 1 2 3) (list 1 4 9)) - (check-equal? ((☯ (~> (loop (~> ▽ (not null?)) - sqr - +))) 1 2 3) - 14)) + (check-equal? ((☯ (loop (~> ▽ (not null?)) + sqr + +)) 1 2 3) + 14) + (check-equal? ((☯ (~> (-< (gen (☯ (~> ▽ (not null?))) + sqr + + + (☯ 0)) + _) + loop)) + 1 2 3) + 14 + "identifier form of loop")) (test-suite "loop2" - (check-equal? ((☯ (~> (loop2 (~> 1> (not null?)) - sqr - cons))) + (check-equal? ((☯ (loop2 (~> 1> (not null?)) + sqr + cons)) (list 1 2 3) null) (list 9 4 1)) - (check-equal? ((☯ (~> (loop2 (~> 1> (not null?)) - sqr - +))) + (check-equal? ((☯ (loop2 (~> 1> (not null?)) + sqr + +)) (list 1 2 3) 0) 14)) @@ -1316,7 +1541,7 @@ "language extension" (test-suite "qi:" - (check-equal? (~> (2 3) + (qi:square sqr)) + (check-equal? ((☯ (~> + (qi:square sqr))) 2 3) 625))) (test-suite @@ -1375,7 +1600,64 @@ (check-equal? ((☯ (~> (pass positive?) +)) 1 -3 5) 6 - "runtime arity changes in threading form")))) + "runtime arity changes in threading form")) + + (test-suite + "nonlocal semantics" + ;; these are collected from counterexamples to candidate equivalences + ;; that turned up during code review. They ensure that some tempting + ;; "equivalences" that are not really equivalences are formally checked + (test-suite + "counterexamples" + (test-suite + "(~> (>< g) (pass f)) ─/→ (>< (~> g (if f _ ⏚)))" + (let () + (define-flow g (-< add1 sub1)) + (define-flow f positive?) + (define (f* x y) (= (sub1 x) (add1 y))) + (define (amp-pass g f) (☯ (~> (>< g) (pass f) ▽))) + (define (amp-if g f) (☯ (~> (>< (~> g (if f _ ground))) ▽))) + (test-equal? "amp-pass" + (apply (amp-pass g f) (range -3 4)) + (list 1 2 3 1 4 2)) + (test-exn "amp-pass" + exn:fail? + (thunk (apply (amp-pass g f*) (range -3 4)))) + (test-exn "amp-if" + exn:fail? + (thunk (apply (amp-if g f) (range -3 4)))) + (test-equal? "amp-if" + (apply (amp-if g f*) (range -3 4)) + (list -2 -4 -1 -3 0 -2 1 -1 2 0 3 1 4 2))) + (let () + (test-equal? "amp-pass" + ((☯ (~> (>< string->number) (pass _))) "a" "2" "c") + 2) + (test-equal? "amp-if" + ((☯ (~> (>< (if _ string->number ground)) ▽)) "a" "2" "c") + (list #f 2 #f)))) + (test-suite + "(~> (>< f) (>< g)) ─/→ (>< (~> f g))" + (test-equal? "amp-amp" + ((☯ (~> (>< (-< add1 sub1)) + (>< (-< sub1 add1)) + ▽)) + 3) + (list 3 5 1 3)) + (test-exn "merged amp" + exn:fail? + (thunk + ((☯ (>< (~> (-< add1 sub1) + (-< sub1 add1)))) + 3)))) + (test-suite + "(~> (== _ ...)) ─/→ _" + (test-exn "relay-_" + exn:fail? + (thunk + ((☯ (== _ _ _)) + 3))) + (test-equal? "relay-_" ((☯ _) 3) 3)))))) (module+ main (void (run-tests tests))) diff --git a/qi-test/tests/macro.rkt b/qi-test/tests/macro.rkt index 252bc6f9..4dcf76e2 100644 --- a/qi-test/tests/macro.rkt +++ b/qi-test/tests/macro.rkt @@ -7,9 +7,9 @@ rackunit/text-ui (only-in math sqr) (only-in racket/function thunk) - (for-syntax syntax/parse - racket/base) + (for-syntax racket/base) syntax/parse/define + syntax/macro-testing "private/util.rkt") (define-qi-syntax-rule (square flo:expr) @@ -81,17 +81,9 @@ (check-equal? ((☯ (macreaux 1 _)) 2) 2) (check-equal? ((☯ (~>> (macreaux _ 1))) 2) 1) ;; note that this is a compile-time error now: - (check-exn exn:fail:syntax? - (thunk - (parameterize ([current-namespace (make-base-empty-namespace)]) - (namespace-require 'racket/base) - (namespace-require 'syntax/parse/define) - (namespace-require 'qi) - (eval - '(begin (define-syntax-parse-rule (macreaux x y) y) - (define-qi-foreign-syntaxes macreaux) - ((☯ (macreaux 1 __)) 2)) - (current-namespace)))) + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (macreaux 1 __)) 2))) "__ template used in a foreign macro shows helpful error") (check-equal? ((☯ saints-macreaux) 5) 10 "can be used in identifier form") (check-equal? (~> (5) double-me) 10 "registered foreign syntax used in identifier form") diff --git a/qi-test/tests/on.rkt b/qi-test/tests/on.rkt index cf08c608..0fec5949 100644 --- a/qi-test/tests/on.rkt +++ b/qi-test/tests/on.rkt @@ -6,8 +6,7 @@ rackunit rackunit/text-ui (only-in math sqr) - (only-in adjutor values->list) - racket/function) + (only-in adjutor values->list)) (define tests (test-suite @@ -21,7 +20,7 @@ (list 5 5) "no clauses, binary") (check-equal? (on () - (const 3)) + (gen 3)) 3 "no arguments")) (test-suite diff --git a/qi-test/tests/qi.rkt b/qi-test/tests/qi.rkt index 3b470508..7edbec6b 100644 --- a/qi-test/tests/qi.rkt +++ b/qi-test/tests/qi.rkt @@ -7,9 +7,11 @@ (prefix-in switch: "switch.rkt") (prefix-in threading: "threading.rkt") (prefix-in definitions: "definitions.rkt") + (prefix-in space: "space.rkt") (prefix-in macro: "macro.rkt") (prefix-in util: "util.rkt") - "private/util.rkt") + (prefix-in expander: "expander.rkt") + (prefix-in compiler: "compiler.rkt")) (define tests (test-suite @@ -20,8 +22,11 @@ switch:tests threading:tests definitions:tests + space:tests macro:tests - util:tests)) + util:tests + expander:tests + compiler:tests)) (module+ test (void diff --git a/qi-test/tests/space.rkt b/qi-test/tests/space.rkt new file mode 100644 index 00000000..39290511 --- /dev/null +++ b/qi-test/tests/space.rkt @@ -0,0 +1,69 @@ +#lang racket/base + +(provide tests) + +(require qi + qi/flow/space + (submod qi/flow/space refer) + rackunit + rackunit/text-ui + (only-in math sqr) + (for-syntax racket/base + syntax/parse)) + +(define tests + (test-suite + "qi binding space tests" + + (test-suite + "define-for-qi" + (let () + (define-for-qi abc 5) + (test-equal? "define and reference in qi space" + (reference-qi abc) + 5)) + (let () + (define-for-qi (abc v) v) + (test-equal? "define and reference a function in qi space" + ((reference-qi abc) 5) + 5)) + (let () + (define-for-qi (abc v . vs) v) + (test-equal? "define and reference a function with rest args in qi space" + ((reference-qi abc) 5 6 7) + 5))) + (test-suite + "define-qi-syntax" + (let () + (define-qi-syntax abc (λ (_) #'add1)) + (test-equal? "define syntax in qi space" + ((☯ abc) 1) + 2)) + (let () + (define-qi-syntax (abc _) #'add1) + (test-equal? "define syntax in qi space, function form" + ((☯ abc) 1) + 2))) + (test-suite + "define-qi-alias" + (let () + (define-for-qi abc 5) + (define-qi-alias pqr abc) + (test-equal? "define an alias for a simple value binding in qi space" + (reference-qi pqr) + 5)) + (let () + (define-for-qi (abc v) v) + (define-qi-alias pqr abc) + (test-equal? "define an alias for a function binding in qi space" + ((reference-qi pqr) 5) + 5)) + (let () + (define-qi-alias my-amp amp) + (test-equal? "define an alias for a Qi syntactic form" + ((☯ (~> (my-amp sqr) ▽)) 1 2 3) + (list 1 4 9)))))) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/threading.rkt b/qi-test/tests/threading.rkt index f1489b9d..30b23136 100644 --- a/qi-test/tests/threading.rkt +++ b/qi-test/tests/threading.rkt @@ -7,7 +7,8 @@ rackunit/text-ui (only-in math sqr) (only-in adjutor values->list) - racket/function) + racket/function + syntax/macro-testing) (define tests (test-suite @@ -16,12 +17,22 @@ "Edge/base cases" (check-equal? (values->list (~> ())) null) (check-equal? (values->list (~>> ())) null) - (check-equal? (~> () (const 5)) 5) - (check-equal? (~>> () (const 5)) 5) + (check-equal? (~> () (gen 5)) 5) + (check-equal? (~>> () (gen 5)) 5) (check-equal? (~> (4)) 4) (check-equal? (~>> (4)) 4) (check-equal? (values->list (~> (4 5 6))) '(4 5 6)) (check-equal? (values->list (~>> (4 5 6))) '(4 5 6))) + (test-suite + "Syntax" + (check-exn exn:fail? + (thunk (convert-compile-time-error + (~> (1 2) sep))) + "catch a common syntax error") + (check-exn exn:fail? + (thunk (convert-compile-time-error + (~>> (1 2) sep))) + "catch a common syntax error")) (test-suite "smoke" (check-equal? (~> (3) sqr add1) 10) diff --git a/qi-test/tests/util.rkt b/qi-test/tests/util.rkt index c3fd8123..9e0510a9 100644 --- a/qi-test/tests/util.rkt +++ b/qi-test/tests/util.rkt @@ -14,12 +14,11 @@ (test-suite "report-syntax-error" (check-exn exn:fail:syntax? - (thunk (report-syntax-error 'dummy - (list 1 2 3) - "blah: blah" - "Use it" - "like" - "this")))))) + (thunk (report-syntax-error #'(dummy 1 2 3) + "blah: blah" + "Use it" + "like" + "this")))))) (module+ main (void (run-tests tests)))