mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 14:30:34 +02:00
Code Activity

Add initial upstream code for srfi-197: Pipeline Operators

Browse source 
https://srfi.schemers.org/srfi-197/srfi-197.html

Add the key files from the upstream implementation.

These files are the unmodified versions from the upstream repository

  https://github.com/scheme-requests-for-implementation/srfi-197.git

as of this commit (final-5-g43eae09):

  commit 43eae0941e4c69b11b5609464b7d8827785c3897
  Author: Arthur A. Gleckler <srfi@speechcode.com>
  Date:   Sun Apr 20 20:30:25 2025 -0700

      Regenerate landing page and README.

except that the upstream LICENSE/MIT.txt referred to by the SPDX headers
has been added to the top of srfi-197.scm and srfi-197.text, and
srfi-197.scm has been reindented. srfi-197.html already includes its own
copyright statement.

srfi-197.scm is upstream srfi-197-syntax-case.scm, and was chosen
instead of upstream srfi-197.scm because Guile doesn't currently handle
syntax-rules with custom elipsis.

For now add the html documentation as-is; convert it to texinfo later.

* doc/ref/srfi-197.html: Add new file.
* module/srfi/srfi-197.scm: Add new file (upstream srfi-197-syntax-case.scm).
* test-suite/tests/srfi-197.test: Add new file (upstream test.scm).
This commit is contained in:
Rob Browning 2025-04-10 13:52:02 -05:00
parent c858253288
commit 2d602d28c3
3 changed files with 562 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

120
doc/ref/srfi-197.html Normal file
View file

File diff suppressed because one or more lines are too long

204
module/srfi/srfi-197.scm Normal file
View file

@ -0,0 +1,204 @@
;;;; SPDX-FileCopyrightText: 2020 Adam R. Nelson <adam@nels.onl>
;;;;
;;;; SPDX-License-Identifier: MIT
;;;;
;;;; MIT License
;;;;
;;;; Copyright (c) 2020 Adam R. Nelson <adam@nels.onl>
;;;;
;;;; Permission is hereby granted, free of charge, to any person
;;;; obtaining a copy of this software and associated documentation
;;;; files (the "Software"), to deal in the Software without
;;;; restriction, including without limitation the rights to use, copy,
;;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;;; of the Software, and to permit persons to whom the Software is
;;;; furnished to do so, subject to the following conditions:
;;;;
;;;; The above copyright notice and this permission notice shall be
;;;; included in all copies or substantial portions of the Software.
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
; A syntax-case implementation of SRFI 197.
; This should be functionally equivalent to srfi-197.scm,
; but it may be easier to read and understand.
(define (gentemp) (car (generate-temporaries '(x))))
(define (id=? x y) (and (identifier? x) (free-identifier=? x y)))
(define-syntax chain
(lambda (x)
(syntax-case x ()
((_ initial-value (step ...) ...)
#'(chain initial-value _ (... ...) (step ...) ...))
((_ initial-value placeholder (step ...) ...)
#'(chain initial-value placeholder (... ...) (step ...) ...))
((_ initial-value placeholder ellipsis) (and (identifier? #'placeholder)
(identifier? #'ellipsis))
#'initial-value)
((_ initial-value placeholder ellipsis (step ...) rest ...)
(let loop ((vars '()) (out '()) (in #'(step ...)))
(syntax-case in ()
((u …) (and (id=? #'u #'placeholder) (id=? #'… #'ellipsis))
(let ((chain-rest-var (gentemp)))
#`(chain (let-values ((#,(if (null? vars)
chain-rest-var
#`(#,@(reverse vars) . #,chain-rest-var))
initial-value))
(apply #,@(reverse out) #,chain-rest-var))
placeholder
ellipsis
rest ...)))
((u … . _) (and (id=? #'u #'placeholder) (id=? #'… #'ellipsis))
(syntax-violation 'chain "_ ... only allowed at end" #'(step ...)))
((u . step-rest) (id=? #'u #'placeholder)
(let ((chain-var (gentemp)))
(loop (cons chain-var vars) (cons chain-var out) #'step-rest)))
((… . _) (id=? #'… #'ellipsis)
(syntax-violation 'chain "misplaced ..." #'(step ...)))
((x . step-rest)
(loop vars (cons #'x out) #'step-rest))
(()
(with-syntax ((result (reverse out)))
#`(chain
#,(cond
((null? vars)
#'(begin initial-value result))
((null? (cdr vars))
#`(let ((#,(car vars) initial-value)) result))
(else
#`(let-values ((#,(reverse vars) initial-value)) result)))
placeholder
ellipsis
rest ...)))))))))
(define-syntax chain-and
(lambda (x)
(syntax-case x ()
((_ initial-value (step ...) ...)
#'(chain-and initial-value _ (step ...) ...))
((_ initial-value placeholder) (identifier? #'placeholder)
#'initial-value)
((_ initial-value placeholder (step ...) rest ...)
(let loop ((var #f) (out '()) (in #'(step ...)))
(syntax-case in ()
((u . step-rest) (id=? #'u #'placeholder)
(if var
(syntax-violation 'chain-and "only one _ allowed per step" #'(step ...))
(let ((chain-var (gentemp)))
(loop chain-var (cons chain-var out) #'step-rest))))
((x . step-rest)
(loop var (cons #'x out) #'step-rest))
(()
(with-syntax ((result (reverse out)))
#`(chain-and
#,(if var
#`(let ((#,var initial-value))
(and #,var result))
#'(and initial-value result))
placeholder
rest ...)))))))))
(define-syntax chain-when
(lambda (x)
(syntax-case x ()
((_ initial-value (guard? (step ...)) ...)
#'(chain-when initial-value _ (guard? (step ...)) ...))
((_ initial-value placeholder) (identifier? #'placeholder)
#'initial-value)
((_ initial-value placeholder (guard? (step ...)) rest ...)
(let loop ((var #f) (out '()) (in #'(step ...)))
(syntax-case in ()
((u . step-rest) (id=? #'u #'placeholder)
(if var
(syntax-violation 'chain-when "only one _ allowed per step" #'(step ...))
(let ((chain-var (gentemp)))
(loop chain-var (cons chain-var out) #'step-rest))))
((x . step-rest)
(loop var (cons #'x out) #'step-rest))
(()
(with-syntax ((result (reverse out)))
#`(chain-when
#,(if var
#`(let ((#,var initial-value))
(if guard? result #,var))
#'(let ((chain-var initial-value))
(if guard? result chain-var)))
placeholder
rest ...)))))))))
(define-syntax chain-lambda
(lambda (x)
(syntax-case x ()
((_ (step ...) ...)
#'(chain-lambda _ (... ...) (step ...) ...))
((_ placeholder (step ...) ...)
#'(chain-lambda placeholder (... ...) (step ...) ...))
((_ placeholder ellipsis (first-step ...) rest ...)
(let loop ((vars '()) (out '()) (in #'(first-step ...)))
(syntax-case in ()
((u …) (and (id=? #'u #'placeholder) (id=? #'… #'ellipsis))
(let ((chain-rest-var (gentemp)))
#`(lambda #,(if (null? vars)
chain-rest-var
#`(#,@vars . #,chain-rest-var))
(chain (apply #,@(reverse out) #,chain-rest-var) placeholder ellipsis rest ...))))
((u … . _) (and (id=? #'u #'placeholder) (id=? #'… #'ellipsis))
(syntax-violation 'chain-lambda "_ ... only allowed at end" #'(first-step ...)))
((u . step-rest) (id=? #'u #'placeholder)
(let ((chain-var (gentemp)))
(loop (cons chain-var vars) (cons chain-var out) #'step-rest)))
((… . _) (id=? #'… #'ellipsis)
(syntax-violation 'chain-lambda "misplaced ..." #'(first-step ...)))
((x . step-rest)
(loop vars (cons #'x out) #'step-rest))
(()
#`(lambda #,(reverse vars) (chain #,(reverse out) placeholder ellipsis rest ...)))))))))
(define-syntax nest
(lambda (x)
(syntax-case x ()
((_ last) #'last)
((_ (step ...) ... last) #'(nest _ (step ...) ... last))
((_ placeholder (extra-step ...) ... (step ...) last)
(let loop ((arg #'last) (out '()) (in #'(step ...)))
(syntax-case in ()
((u . step-rest) (id=? #'u #'placeholder)
(if (eof-object? arg)
(syntax-violation 'nest "only one _ allowed per step" #'(step ...))
(loop (eof-object) (cons arg out) #'step-rest)))
((x . step-rest)
(loop arg (cons #'x out) #'step-rest))
(()
(if (eof-object? arg)
#`(nest placeholder (extra-step ...) ... #,(reverse out))
(syntax-violation 'nest "step must contain _" #'(step ...)))))))
((_ placeholder last) #'last))))
(define-syntax nest-reverse
(lambda (x)
(syntax-case x ()
((_ first) #'first)
((_ first (step ...) ...) #'(nest-reverse first _ (step ...) ...))
((_ first placeholder (step ...) (extra-step ...) ...)
(let loop ((arg #'first) (out '()) (in #'(step ...)))
(syntax-case in ()
((u . step-rest) (id=? #'u #'placeholder)
(if (eof-object? arg)
(syntax-violation 'nest-reverse "only one _ allowed per step" #'(step ...))
(loop (eof-object) (cons arg out) #'step-rest)))
((x . step-rest)
(loop arg (cons #'x out) #'step-rest))
(()
(if (eof-object? arg)
#`(nest-reverse #,(reverse out) placeholder (extra-step ...) ...)
(syntax-violation 'nest-reverse "step must contain _" #'(step ...)))))))
((_ first placeholder) #'first))))

238
test-suite/tests/srfi-197.test Normal file
View file

@ -0,0 +1,238 @@
;;;; SPDX-FileCopyrightText: 2020 Adam R. Nelson <adam@nels.onl>
;;;;
;;;; SPDX-License-Identifier: MIT
;;;;
;;;; MIT License
;;;;
;;;; Copyright (c) 2020 Adam R. Nelson <adam@nels.onl>
;;;;
;;;; Permission is hereby granted, free of charge, to any person
;;;; obtaining a copy of this software and associated documentation
;;;; files (the "Software"), to deal in the Software without
;;;; restriction, including without limitation the rights to use, copy,
;;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;;; of the Software, and to permit persons to whom the Software is
;;;; furnished to do so, subject to the following conditions:
;;;;
;;;; The above copyright notice and this permission notice shall be
;;;; included in all copies or substantial portions of the Software.
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
(include "./srfi-64-minimal.scm")
(define (exclamation x) (string-append x "!"))
(define (foo+bar x) (values (string-append x "foo") (string-append x "bar")))
(test-begin "Pipeline Operators")
(test-equal "chain" "bazbarfoo!"
(chain ""
(string-append "foo" _)
(string-append "bar" _)
(string-append "baz" _)
(exclamation _)))
(test-equal "chain with mixed _ position" "barfoobaz"
(chain ""
(string-append _ "foo")
(string-append "bar" _)
(string-append _ "baz")))
(test-equal "chain with _ in operator position" 3
(chain +
(_ 1 2)))
(test-equal "chain without _" "barbazqux"
(chain ""
(string-append _ "foo")
(string-append "bar" "baz")
(string-append _ "qux")))
(test-equal "chain multiple _" "quxfoo/quxbar"
(chain "qux"
(foo+bar _)
(string-append _ "/" _)))
(test-equal "chain _ ..." "bazquxfooquxbar"
(chain "qux"
(foo+bar _)
(string-append "baz" _ ...)))
(test-equal "chain _ _ ..." "quxfoobazquxbar"
(chain "qux"
(foo+bar _)
(string-append _ "baz" _ ...)))
(test-equal "chain with custom _" "bazbarfoo!"
(chain "" <>
(string-append "foo" <>)
(string-append "bar" <>)
(string-append "baz" <>)
(exclamation <>)))
(test-equal "chain with custom ..." "bazquxfooquxbar"
(chain "qux" - ---
(foo+bar -)
(string-append "baz" - ---)))
(test-equal "chain-and" "bazbarfoo!"
(chain-and ""
(string-append "foo" _)
(string-append "bar" _)
(string-append "baz" _)
(exclamation _)))
(test-equal "chain-and with mixed _ position" "barfoobaz"
(chain-and ""
(string-append _ "foo")
(string-append "bar" _)
(string-append _ "baz")))
(test-equal "chain-and without _" "barbazqux"
(chain-and ""
(string-append "foo" _)
(string-append "bar" "baz")
(string-append _ "qux")))
(test-equal "chain-and short-circuit" #f
(chain-and ""
(string-append "foo" _)
(equal? _ "bar")
(string-append "baz" _)
(exclamation _)))
(test-equal "chain-and short-circuit first" #f
(chain-and #f
(not _)))
(test-equal "chain-and with custom _" "bazbarfoo!"
(chain-and "" <>
(string-append "foo" <>)
(string-append "bar" <>)
(string-append "baz" <>)
(exclamation <>)))
(test-equal "chain-when" "bazfoo"
(chain-when ""
((= (+ 2 2) 4) (string-append "foo" _))
((= (+ 2 2) 5) (string-append "bar" _))
(#t (string-append "baz" _))))
(test-equal "chain-when with mixed _ position" "barfooqux"
(chain-when ""
(#t (string-append _ "foo"))
(#t (string-append "bar" _))
(#f (string-append _ "baz"))
(#t (string-append _ "qux"))))
(test-equal "chain-when without _" "barqux"
(chain-when ""
(#t (string-append _ "foo"))
(#t (string-append "bar"))
(#f (string-append _ "baz"))
(#t (string-append _ "qux"))))
(test-equal "chain-when with custom _" "bazfoo"
(chain-when "" <>
((= (+ 2 2) 4) (string-append "foo" <>))
((= (+ 2 2) 5) (string-append "bar" <>))
(#t (string-append "baz" <>))))
(test-equal "chain-lambda" "bazbarfoo!"
((chain-lambda (string-append "foo" _)
(string-append "bar" _)
(string-append "baz" _)
(exclamation _))
""))
(test-equal "chain-lambda one step" "foobar"
((chain-lambda (string-append "foo" _)) "bar"))
(test-equal "chain-lambda with mixed _ position" "barfoobaz"
((chain-lambda (string-append _ "foo")
(string-append "bar" _)
(string-append _ "baz"))
""))
(test-equal "chain-lambda multiple _" "foobarbazqux"
((chain-lambda (string-append _ "bar" _)
(string-append _ "qux"))
"foo"
"baz"))
(test-equal "chain-lambda without _" "barqux"
((chain-lambda (string-append "bar")
(string-append _ "qux"))))
(test-equal "chain-lambda _ ..." "foobarbazqux"
((chain-lambda (string-append "foo" _ ...)
(string-append _ "qux"))
"bar"
"baz"))
(test-equal "chain-lambda _ _ ..." "foobarbazquxquux"
((chain-lambda (string-append _ "bar" _ ...)
(string-append _ "quux"))
"foo"
"baz"
"qux"))
(test-equal "chain-lambda with custom _" "bazbarfoo!"
((chain-lambda <>
(string-append "foo" <>)
(string-append "bar" <>)
(string-append "baz" <>)
(exclamation <>))
""))
(test-equal "chain-lambda with custom ..." "foobarbazqux"
((chain-lambda - ---
(string-append "foo" - ---)
(string-append - "qux"))
"bar"
"baz"))
(test-equal "nest" '(1 2 (3 (4) 5))
(nest (quote _)
(1 2 _)
(3 _ 5)
(_)
4))
(test-equal "nest with custom _" '(1 2 (3 (4) 5))
(nest <>
(quote <>)
(1 2 <>)
(3 <> 5)
(<>)
4))
(test-equal "nested nest" '(1 2 3 (4 5 6))
(nest (nest _2 (quote _2) (1 2 3 _2) _ 6)
(_ 5 _2)
4))
(test-equal "nest-reverse" '(1 2 (3 (4) 5))
(nest-reverse 4
(_)
(3 _ 5)
(1 2 _)
(quote _)))
(test-equal "nest-reverse with custom _" '(1 2 (3 (4) 5))
(nest-reverse 4 <>
(<>)
(3 <> 5)
(1 2 <>)
(quote <>)))
(test-end "Pipeline Operators")