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

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")