From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Janneke Nieuwenhuizen Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Add srfi-235: Combinators. Date: Wed, 19 Jun 2024 11:49:23 +0200 Message-ID: <20240619094925.13037-1-janneke@gnu.org> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="29010"; mail-complaints-to="usenet@ciao.gmane.io" To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Wed Jun 19 11:50:16 2024 Return-path: Envelope-to: guile-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1sJrxH-0007LD-Og for guile-devel@m.gmane-mx.org; Wed, 19 Jun 2024 11:50:15 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1sJrwi-0007Ou-SR; Wed, 19 Jun 2024 05:49:41 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1sJrwZ-0007M5-BR for guile-devel@gnu.org; Wed, 19 Jun 2024 05:49:32 -0400 Original-Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1sJrwZ-0000Xg-3Q; Wed, 19 Jun 2024 05:49:31 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:Date:Subject:To:From:in-reply-to: references; bh=KaIM2EHmlXVAfexXKCfheY8+uStOMG4FsVuGcTM1oFI=; b=qXnCGRN+ELlJ/H NlUg3Tsh6VTf3TTwce8pgd/LzstnQslmqSS8sY2WzeZrd210MwQeFHRdaiiDc1zPZfrDio4T/OeMY dqNUa435b1POSgkmJ+LsmrKMgHiuD03hn54n986/i5V1Z5l9hR1ZJStp1muSgbWaDQ/zW59c9p2nd +Xrcg9rBQvDBSSjWexL9yUgBanz4cZuPpjfaSW6eRETv8cIlAyOlx+2IeyZ+/OcLliNkLmCJw5ReH PEU0+jCef91HoYQTHccYxNEWDa8nS/hX2pRi9B0W7+KETUWJaJPvf3HEBme2MDzK8wT+L5YUS3Y1S nOPKa5XeeLVSDF5ITfyw==; X-Mailer: git-send-email 2.45.1 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.devel:22449 Archived-At: Imported reference implementation, test, and documentation from . * module/srfi/srfi-235.scm: New file. * am/bootstrap.am (SOURCES): Register it. * test-suite/tests/srfi-235.test: New file. * test-suite/Makefile.am (SCM_TESTS): Register it. * doc/ref/srfi-modules.texi (SRFI-235): Document it. --- am/bootstrap.am | 1 + doc/ref/srfi-modules.texi | 477 +++++++++++++++++++++++++++++++- module/srfi/srfi-235.scm | 311 +++++++++++++++++++++ test-suite/Makefile.am | 3 +- test-suite/tests/srfi-235.test | 485 +++++++++++++++++++++++++++++++++ 5 files changed, 1274 insertions(+), 3 deletions(-) create mode 100644 module/srfi/srfi-235.scm create mode 100644 test-suite/tests/srfi-235.test diff --git a/am/bootstrap.am b/am/bootstrap.am index 9e5fca0db..74df9e9e6 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -351,6 +351,7 @@ SOURCES = \ srfi/srfi-171.scm \ srfi/srfi-171/gnu.scm \ srfi/srfi-171/meta.scm \ + srfi/srfi-235.scm \ \ statprof.scm \ \ diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 02da3e2f2..9e88a92ad 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020 +@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020, 2024 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -65,7 +65,8 @@ get the relevant SRFI documents from the SRFI home page * SRFI-105:: Curly-infix expressions. * SRFI-111:: Boxes. * SRFI-119:: Wisp: simpler indentation-sensitive Scheme. -* SRFI-171:: Transducers +* SRFI-171:: Transducers. +* SRFI-235:: Combinators. @end menu @@ -6179,6 +6180,478 @@ The generator version of list-reduce. It reduces over @code{gen} until it returns the EOF object @end deffn + +@node SRFI-235 +@subsection Combinators +@cindex SRFI-235 +@cindex combinators + +@uref{https://srfi.schemers.org/srfi-235/srfi-235.html, SRFI-235} +provides various procedures that accept and return procedures, as well +as a few others, drawn from +@uref{https://wiki.call-cc.org/eggref/4/combinators,an earlier version +of Chicken}. Common Lisp has a few of them too, and more come from +@uref{https://programmingpraxis.com/contents/standard-prelude/,the +Standard Prelude from @emph{Programming Praxis}}. Using these +procedures helps to keep code terse and reduce the need for ad hoc +lambdas. + +@menu +* SRFI-235 Rationale:: +* SRFI-235 Specification:: +* SRFI-235 Syntax-like procedures:: +* SRFI-235 Other procedures:: +@end menu + +@node SRFI-235 Rationale +@section Rationale +@anchor{#rationale} +Many procedures such as @code{map}, @code{filter}, @code{fold}, and +their equivalents for data structures other than lists accept an +argument specifying the behavior to be performed on each element of the +data structure. This can be done in one of two ways: + +@itemize +@item +The code uses a @code{lambda} to describe the needed behavior +@item +The code is placed in an internal or external @code{define}, which +requires finding a good name and splits the action into different +locations, making the code harder to read. +@end itemize + +Those composition procedures, called @emph{combinators}, have been +identified by the Scheme and Common Lisp communities as reducing such +fragmentation while keeping the code dense. + +@node SRFI-235 Specification +@section Specification +@anchor{#specification} + +@deffn {Scheme Procedure} (constantly obj @dots{}) arg @dots{} + +Return the @emph{objs} as its values, ignoring @emph{args}. + +@example +(map (constantly 3) '(1 2 3)) => (3 3 3) +@end example +@end deffn + +@deffn {Scheme Procedure} (complement proc) obj + +Return @code{#t} when @code{(}@emph{proc obj}@code{)} returns +@code{#f}, and @code{#f} otherwise. + +@example +(map (complement (lambda (x) #f)) '(1 2 3)) => (#t #t #t) +(map (complement (lambda (x) 3)) '(1 2 3)) => (#f #f #f) +@end example +@end deffn + +@deffn {Scheme Procedure} (flip proc) . objs + +Return what @code{(apply}@ @emph{proc} @code{(reverse}@ @emph{objs} +@code{)} returns. + +@example +((flip list) 1 2 3) => (3 2 1) +@end example +@end deffn + +@deffn {Scheme Procedure} (swap proc) . obj₁ obj₂ . objs + +Return @code{(apply}@ @emph{proc obj₂ obj₁ objs}@code{)}. + +@example +((swap cons) 1 2) => (2 . 1) +@end example +@end deffn + +@deffn (Scheme Procedure) (on-left proc) obj₁ obj₂ + +Return (@emph{proc obj₁}). + +@example +(map (on-left list) '(1 2 3) '(4 5 6)) => '((1) (2) (3)) +@end example +@end deffn + +@deffn (Scheme procedure) (on-right proc) obj₁ obj₂ + +Return (@emph{proc obj₂}). + +@example +(map (on-right list) '(1 2 3) '(4 5 6)) => '((4) (5) (6)) +@end example +@end deffn + +@deffn (Scheme procedure) (conjoin predicate @dots{} arg @dots{} + +The @emph{predicates} are applied in turn to the @emph{args} as follows: +If a call to a predicate returns false, no more predicates are applied +and @code{#f} is returned. If all predicates return true, then the last +value is returned. If there are no predicates, @code{#t} is returned. + +@example +(map (conjoin even? exact?) '(1.0 1 2.0 2)) => '(#f #f #f #t) +@end example +@end deffn + +@deffn (Scheme procedure) (disjoin predicate @dots{} arg @dots{} + +The @emph{predicates} are applied in turn to the @emph{args} as follows: +If a call to a predicate returns true, no more predicates are applied +and its value is returned. If all predicates return false, then the last +value is returned. If there are no predicates, @code{#f} is returned. + +@example +(map (disjoin even? exact?) '(1.0 1 2.0 2)) => '(#f #t #t #t) +@end example +@end deffn + +@deffn (Scheme procedure) (each-of proc @dots{} arg @dots{} + +Applies each of the @emph{procs} in turn to @emph{args}, discarding the +results and returning an unspecified value. + +@example +(define (print-sum . numbers) + (display + (string-join (map number->string numbers) + "+" 'infix)) + (newline)) + +(define (print-product . numbers) + (display + (string-join (map number->string numbers) + "*" 'infix)) + (newline)) + +((each-of print-sum print-product) 1 2 3) => undefined ;prints: +1+2+3 +1*2*3 +@end example +@end deffn + +@deffn (Scheme procedure) (all-of predicate) list + +Applies @emph{predicate} to each element of @emph{list} in turn, and +immediately returns @code{#f} if @emph{predicate} is not satisfied by +that element. If every element satisfies @emph{predicate}, returns the +result of the last call to @emph{predicate}. If @emph{list} is empty, +returns @code{#t}. + +@example +((all-of even?) '(2 4 6)) => #t +((all-of odd?) '(1 2 3)) => #f +@end example +@end deffn + +@deffn (Scheme procedure) (any-of predicate) list + +Applies @emph{predicate} to each element of @emph{list} in turn, and if +@emph{predicate} is satisfied by that element, immediately returns the +result of calling @emph{predicate}. If no element satisfies +@emph{predicate} returns @code{#f}. If @emph{list} is empty, returns +@code{#f}. + +@example +((any-of even?) '(2 4 5)) => #t +((any-of odd?) '(2 4 6)) => #f +@end example +@end deffn + +@deffn (Scheme procedure) (on reducer mapper) obj₁ obj @dots{} + +Applies @emph{mapper} to each @emph{obj} in any order and then applies +@emph{reducer} to all of the results in left to right order. + +@example +((on + -) 1 2 3) => -6 +@end example +@end deffn + +@deffn (Scheme procedure) (left-section proc arg @dots{} obj @dots{} + +Applies @emph{proc} to @emph{args} concatenated with @emph{objs}. + +@example +(map (left-section - 1) '(1 2 3)) => (0 -1 -2) +@end example +@end deffn + +@deffn (Scheme procedure) (right-section proc arg @dots{} obj @dots{} + +Applies @emph{proc} to @emph{objs} concatenated with the value of +@code{(reverse}@ @emph{args}@code{)}. + +@example +(map (right-section - 1) '(1 2 3)) => (0 1 2) +@end example +@end deffn + +@deffn (Scheme procedure) (apply-chain@ proc₁ proc @dots{} arg @dots{}` + +Applies the last @emph{proc} to @emph{args} returning zero or more +values, then applies the previous @emph{proc} to the values, returning +more values, until the first proc has been invoked; its values are +returned. For example, @code{(apply-chain car cdr)} returns a procedure +that behaves like @code{cadr}: + +@example +(map (apply-chain car cdr) '((1 2 3) (4 5 6))) => (2 5) +@end example +@end deffn + +@deffn (Scheme procedure) (arguments-drop proc n) arg @dots{}@* +@deffnx (Scheme procedure) (arguments-drop-right proc n) arg @dots{}@* +@deffnx (Scheme procedure) (arguments-take proc n) arg @dots{}@* +@deffnx (Scheme procedure) (arguments-take-right proc n) arg @dots{} + +Apply @emph{proc} to the @emph{args} after taking/dropping @emph{n} +arguments from @emph{args}. + +@example +(apply (arguments-drop + 2) '(1 2 3 4 5)) => 12 +(apply (arguments-drop-right + 2) '(1 2 3 4 5)) => 6 +(apply (arguments-take + 2) '(1 2 3 4 5)) => 3 +(apply (arguments-take-right + 2) '(1 2 3 4 5)) => 9 +@end example +@end deffn + +@deffn (Scheme procedure) (group-by key-proc [=]) list + +Takes the elements of @emph{list} and applies @emph{key-proc} to each of +them to get their keys. Elements whose keys are the same (in the sense +of =, which defaults to @code{equal?}) are grouped into newly allocated +lists, and a list of these lists is returned. Within each list, the +elements appear in the same order as they do in @emph{list}; in +addition, the first elements of each list also appear in the same order +as they do in @emph{list}. If @emph{list} is the empty list, it is +returned. + +@example +((group-by car) '((1 2 3) (2 2 3) (1 4 5))) => + (((1 2 3) (1 4 5)) + ((2 2 3)) +@end example +@end deffn + +@node SRFI-235 Syntax-like procedures +@section Syntax-like procedures +@anchor{#syntax-like-procedures} +These are Scheme procedures that correspond to basic syntax. As usual in +Lisps, @emph{thunk} means a procedure that does not require arguments. + +The following procedures are understood to be defined in this section: + +@example + (define (a) (display #\a)) + (define (b) (display #\b)) + (define (c) (display #\c)) + (define (z) (display #\z)) +@end example + +@deffn (Scheme procedure) begin-procedure thunk @dots{} + +Invokes @emph{thunks} in order, and returns what the last thunk returns, +or an unspecified value if there are no thunks. + +@example +(begin-procedure a b c) => unspecified (displays "abc") +@end example +@end deffn + +@deffn (Scheme procedure) if-procedure value then-thunk else-thunk + +If @emph{value} is true, invokes @emph{then-thunk} and returns what it +returns. Otherwise, invokes @emph{else-thunk} and returns what it +returns. + +@example +(if-procedure #t (lambda () 1) (lambda () 2)) => 1 +(if-procedure #f (lambda () 1) (lambda () 2)) => 2 +@end example +@end deffn + +@deffn (Scheme procedure) when-procedure value thunk @dots{} +@deffnx (Scheme procedure) unless-procedure value thunk @dots{} + +If @emph{value} is false/true, immediately returns. Otherwise, invokes +each @emph{thunk} in turn and then returns. In all cases an unspecified +value is returned. + +@example +(when-procedure #t a b c) => unspecified ;prints "abc" +(when-procedure #f a b c) => unspecified ;prints nothing +(unless-procedure #t a b c) => unspecified ;prints nothing +(unless-procedure #f a b c) => unspecified ;prints "abc" +@end example +@end deffn + +@deffn (Scheme procedure) value-procedure value then-proc else-thunk + +If @emph{value} is true, invokes @emph{then-proc} on it and returns what +@emph{then-proc} returns. Otherwise, invokes @emph{else-thunk} and +returns what it returns. + +@example +(value-procedure 2 (lambda (x) (+ x 1)) (lambda () 0)) => 3) +(value-procedure #f (lambda (x) (+ x 1)) (lambda () 0)) => 0) +@end example +@end deffn + +@deffn (Scheme procedure) case-procedure value thunk-alist [ else-thunk + +Searches @emph{thunk-alist} for @emph{value} (as if by @code{assv}). If +there is a matching entry in @emph{thunk-alist}, its cdr is invoked as a +thunk, and @code{case-procedure} returns what the thunk returns. If +there is no such entry in @emph{thunk-alist}, invokes @emph{else-thunk} +(if present) and returns what it returns. If @emph{else-thunk} is not +present, the result is undefined. + +@example +(case-procedure 0 `((1 . ,a) (2 . ,z) (3 . ,c)) z) => undefined ;displays "z" +(case-procedure 0 `((1 . ,a) (2 . ,z) (3 . ,c))) => undefined ;displays nothing +(case-procedure 2 `((1 . ,a) (2 . ,b) (3 . ,c))) => undefined ;displays "b" +@end example +@end deffn + +@deffn (Scheme procedure) and-procedure thunk @dots{} + +The thunks are invoked from left to right, and if any thunk returns +false, then @code{#f} is returned. Any remaining thunks are not invoked. +If all the thunks return true values, the values of the last thunk are +returned. If there are no thunks, then @code{#t} is returned. + +@example +(and-procedure + (lambda () #t) + (lambda () #f) + (lambda () (error "fail"))) => #f +@end example +@end deffn + +@deffn (Scheme procedure) eager-and-procedure@ thunk @dots{} + +All the thunks are invoked from left to right. If any thunk returns +false, then @code{#f} is returned. If all the thunks return true values, +the value of the last thunk is returned. If there are no thunks, then +@code{#t} is returned. + +@example +(eager-and-procedure + (lambda () #t) + (lambda () #f) + (lambda () (error "fail"))) => error +@end example +@end deffn + +@deffn (Scheme procedure) or-procedure thunk @dots{} + +The thunks are invoked from left to right, and the first true value is +returned. Any remaining thunks are not invoked. If all thunks return +@code{#f} or if there are no thunks, then @code{#f} is returned. + +@example +(or-procedure + (lambda () #t) + (lambda () #f) + (lambda () (error "fail"))) => #t +@end example +@end deffn + +@deffn (Scheme procedure) eager-or-procedure@ thunk @dots{} + +All the thunks are invoked from left to right, and then the first true +value is returned. If all thunks return @code{#f} or if there are no +thunks, then @code{#f} is returned. + +@example +(eager-or-procedure + (lambda () #t) + (lambda () #f) + (lambda () (error "fail"))) => error +@end example +@end deffn + +@deffn (Scheme procedure) funcall-procedure thunk + +Invokes @emph{thunk} once, and returns what it returns. Note that the +name @code{funcall} is derived from Common Lisp. + +@code{(loop-procedure}@ @emph{thunk}@code{)} + +Invokes @emph{thunk} repeatedly. Does not return unless via +@code{call/cc}. + +@example +(loop-procedure (lambda () (a) (b))) => ; #displays "abab@dots{}" forever +@end example +@end deffn + +@deffn (Scheme procedure) while-procedure@ thunk + +Invokes @emph{thunk} repeatedly until it returns false. Return an +unspecified value. + +@example +(let ((i 0)) + (while-procedure + (lambda () + (display i) + (set! i (+ i 1)) + (< i 10)))) => unspecified ;prints "0123456789" +@end example +@end deffn + +@deffn (Scheme procedure until-procedure thunk + +Invokes @emph{thunk} repeatedly until it returns true. Return an +unspecified value. + +@example +(let ((i 10)) + (until-procedure + (lambda () + (set! i (- i 1)) + (display i) + (> i 0)))) => unspecified ;prints "9876543210" +@end example +@end deffn + +@node SRFI-235 Other procedures +@section Other procedures +@anchor{#other-procedures} + +@deffn (Scheme procedure) always@ obj @dots{} + +Ignores its arguments and always returns @code{#t}. + +@example +(always 1 2 3) => #t +@end example +@end deffn + +@deffn (Scheme procedure never obj @dots{} + +Ignores its arguments and always returns @code{#f}. + +@example +(never 1 2 3) => #f +@end example +@end deffn + +@deffn boolean obj + +If @emph{obj} is true, returns @code{#t}; otherwise returns @code{#f}. + +@example +(boolean 3) => #t +(boolean #f) => #f +@end example +@end deffn + @c srfi-modules.texi ends here @c Local Variables: diff --git a/module/srfi/srfi-235.scm b/module/srfi/srfi-235.scm new file mode 100644 index 000000000..25cca6edd --- /dev/null +++ b/module/srfi/srfi-235.scm @@ -0,0 +1,311 @@ +;;; srfi-235.scm -- SRFI 235 Combinators + +;; Copyright (C) 2024 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (srfi srfi-235) + #:use-module (srfi srfi-1) + #:export (constantly + complement + swap + flip + on-left + on-right + conjoin + disjoin + each-of + all-of + any-of + on + left-section + right-section + apply-chain + arguments-drop + arguments-drop-right + arguments-take + arguments-take-right + group-by + + begin-procedure + if-procedure + when-procedure + unless-procedure + value-procedure + case-procedure + and-procedure + eager-and-procedure + or-procedure + eager-or-procedure + funcall-procedure + loop-procedure + while-procedure + until-procedure + + always + never + boolean)) + +(cond-expand-provide (current-module) '(srfi-235)) + +(define (constantly . args) + (lambda ignored-args + (apply values args))) + +(define (complement proc) + (lambda (obj) + (not (proc obj)))) + +(define (swap proc) + (lambda (obj1 obj2 . rest) + (apply proc obj2 obj1 rest))) + +(define (flip proc) + (lambda args + (apply proc (reverse args)))) + +(define (on-left proc) + (lambda (obj1 obj2) + (proc obj1))) + +(define (on-right proc) + (lambda (obj1 obj2) + (proc obj2))) + +(define (conjoin . predicates) + (case-lambda + (() #t) + (args (let loop-args ((args args)) + (or (null? args) + (let ((arg (car args))) + (let loop-preds ((predicates predicates)) + (cond + ((null? predicates) (loop-args (cdr args))) + ((not ((car predicates) arg)) #f) + (else (loop-preds (cdr predicates))))))))))) + +(define (disjoin . predicates) + (case-lambda + (() #t) + (args (let loop-args ((args args)) + (or (null? args) + (let ((arg (car args))) + (let loop-preds ((predicates predicates)) + (cond + ((null? predicates) #f) + (((car predicates) arg) (loop-args (cdr args))) + (else (loop-preds (cdr predicates))))))))))) + +(define (each-of . procs) + (lambda args + (for-each + (lambda (proc) (apply proc args)) + procs))) + +(define (all-of predicate) + (lambda (lst) + (let loop ((lst lst) + (last #t)) + (cond + ((null? lst) last) + ((predicate (car lst)) => (lambda (value) + (loop (cdr lst) value))) + (else #f))))) + +(define (any-of predicate) + (lambda (lst) + (and (not (null? lst)) + (let loop ((lst lst)) + (cond + ((null? lst) #f) + ((predicate (car lst))) + (else (loop (cdr lst)))))))) + +(define (on reducer mapper) + (lambda objs + (apply reducer (map mapper objs)))) + +(define (left-section proc . args) + (lambda objs + (apply proc (append args objs)))) + +(define (right-section proc . args) + (let ((args-reverse (reverse args))) + (lambda objs + (apply proc (append objs args-reverse))))) + +(define (apply-chain . procs) + (define procs/rev (reverse procs)) + (lambda args + (let loop ((values-provider (lambda () (apply values args))) + (procs procs/rev)) + (if (null? procs) + (values-provider) + (loop (lambda () + (call-with-values + values-provider + (car procs))) + (cdr procs)))))) + +(define (arguments-drop/take proc drop/take n) + (lambda args + (apply proc (drop/take args n)))) + +(define (arguments-drop proc n) + (arguments-drop/take proc drop n)) + +(define (arguments-drop-right proc n) + (arguments-drop/take proc drop-right n)) + +(define (arguments-take proc n) + (arguments-drop/take proc take n)) + +(define (arguments-take-right proc n) + (arguments-drop/take proc take-right n)) + +(define group-by + (case-lambda + ((key-proc) (group-by key-proc equal?)) + ((key-proc =) + (lambda (lst) + (let loop ((lst lst) + (mapping-alist '())) + (cond + ((null? lst) + (reverse + (map + (lambda (entry) + (reverse (cdr entry))) + mapping-alist))) + (else + (let* ((value (car lst)) + (key (key-proc value))) + (cond + ((assoc key mapping-alist =) + => + (lambda (entry) + (set-cdr! entry (cons value (cdr entry))) + (loop (cdr lst) + mapping-alist))) + (else (loop (cdr lst) + (cons (cons key (list value)) + mapping-alist)))))))))))) + +(define (begin-procedure . thunks) + (let loop ((value (if #f #f)) + (thunks thunks)) + (if (null? thunks) + value + (loop ((car thunks)) + (cdr thunks))))) + +(define (if-procedure value then-thunk else-thunk) + (if value + (then-thunk) + (else-thunk))) + +(define (when-procedure value . thunks) + (when value + (for-each + (lambda (fn) (fn)) + thunks))) + +(define (unless-procedure value . thunks) + (unless value + (for-each + (lambda (fn) (fn)) + thunks))) + +(define (value-procedure value then-proc else-thunk) + (if value + (then-proc value) + (else-thunk))) + +(define case-procedure + (case-lambda + ((value thunk-alist) + (case-procedure value thunk-alist (lambda args (if #f #f)))) + ((value thunk-alist else-thunk) + (cond + ((assv value thunk-alist) => (lambda (entry) + ((cdr entry)))) + (else (else-thunk)))))) + +(define and-procedure + (case-lambda + (() #t) + (thunks (let loop ((thunks thunks)) + (cond + ((null? (cdr thunks)) ((car thunks))) + ((not ((car thunks))) #f) + (else (loop (cdr thunks)))))))) + +(define eager-and-procedure + (case-lambda + (() #t) + (thunks (let loop ((thunks thunks) + (result #t)) + (cond + ((null? (cdr thunks)) (let ((r ((car thunks)))) + (and result r))) + ((not ((car thunks))) (loop (cdr thunks) #f)) + (else (loop (cdr thunks) result))))))) + +(define or-procedure + (case-lambda + (() #f) + (thunks (let loop ((thunks thunks)) + (cond + ((null? thunks) #f) + (((car thunks)) => values) + (else (loop (cdr thunks)))))))) + +(define eager-or-procedure + (case-lambda + (() #f) + (thunks (let loop ((thunks thunks) + (result #f)) + (cond + ((null? thunks) result) + (((car thunks)) => (lambda (res) + (loop (cdr thunks) + (or result + res)))) + (else (loop (cdr thunks) result))))))) + +(define (funcall-procedure thunk) + (thunk)) + +(define (loop-procedure thunk) + (thunk) + (loop-procedure thunk)) + +(define (while-procedure thunk) + (if (thunk) + (while-procedure thunk) + #f)) + +(define (until-procedure thunk) + (define v (thunk)) + (if v + v + (until-procedure thunk))) + +(define (always . args) #t) + +(define (never . args) #f) + +(define (boolean obj) + (if obj #t #f)) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 247d97746..f83c942d9 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright 2001-2020, 2023 Software Foundation, Inc. +## Copyright 2001-2020, 2023, 2024 Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -164,6 +164,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-111.test \ tests/srfi-119.test \ tests/srfi-171.test \ + tests/srfi-235.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ diff --git a/test-suite/tests/srfi-235.test b/test-suite/tests/srfi-235.test new file mode 100644 index 000000000..535488605 --- /dev/null +++ b/test-suite/tests/srfi-235.test @@ -0,0 +1,485 @@ +;;;; srfi-235.test --- Test suite for SRFI-235 Combinators. -*- scheme -*- +;;;; +;;;; Copyright (C) 2024 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-srfi-235) + ;; #:use-module (test-suite lib) + ;; #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-235)) + +(test-begin "Combinators") + +(test-group + "constantly" + + (test-equal '(1 2) + (call-with-values + (lambda () ((constantly 1 2) 'a 'b)) + list)) + + (test-equal '(1) + (call-with-values + (lambda () ((constantly 1) 'a 'b)) + list)) + + (test-equal '() + (call-with-values + (lambda () ((constantly) 'a 'b)) + list))) + + +(test-group + "complement" + + (test-equal #f + ((complement symbol?) 'a)) + + (test-equal #t + ((complement symbol?) 1))) + + +(test-group + "swap" + + (test-equal '(2 1 3 4) + ((swap list) 1 2 3 4))) + + +(test-group + "flip" + + (test-equal '(4 3 2 1) + ((flip list) 1 2 3 4))) + + +(test-group + "on-left" + + (test-equal '(1) + ((on-left list) 1 2))) + + +(test-group + "on-right" + + (test-equal '(2) + ((on-right list) 1 2))) + + +(test-group + "conjoin" + + (test-assert + ((conjoin number? exact?))) + + (test-assert + ((conjoin number? exact?) 1 2)) + + (test-assert + (not ((conjoin number? exact?) 1 2.))) + + (test-assert + ((conjoin) 1 2))) + + +(test-group + "disjoin" + + (test-assert + ((disjoin number? string?))) + + (test-assert + ((disjoin number? string?) 1 "a")) + + (test-assert + (not ((disjoin number? string?) 'a 'b))) + + (test-assert + (not ((disjoin) 1 2)))) + + +(test-group + "each-of" + + (let ((r1 #f) + (r2 #f)) + ((each-of + (lambda args (set! r1 args)) + (lambda args (set! r2 args))) + 1 2) + (test-equal r1 '(1 2)) + (test-equal r2 '(1 2)))) + + +(test-group + "all-of" + + (test-assert + ((all-of string?) '())) + + (test-assert + ((all-of string?) '("a" "b"))) + + (test-equal + "b" + ((all-of values) '("a" "b"))) + + (test-assert + (not ((all-of string?) '("a" b)))) + + (test-assert + (not ((all-of (lambda (x) + (when (equal? x 'c) + ;; should short circuit before this point + (test-assert #f)) + (string? x))) + '("a" b c))))) + + +(test-group + "any-of" + + (test-assert + (not ((any-of string?) '()))) + + (test-assert + ((any-of string?) '("a" b))) + + (test-equal + "a" + ((any-of values) '("a" "b"))) + + (test-assert + (not ((any-of string?) '(a b)))) + + (test-assert + ((any-of (lambda (x) + (when (equal? x 'b) + ;; should short circuit before this point + (test-assert #f)) + (string? x))) + '("a" b)))) + + +(test-group + "on" + + (test-equal '(2 3 4) + ((on list (lambda (x) (+ 1 x))) 1 2 3))) + + +(test-group + "left-section" + + (test-equal '(1 2 3 4) + ((left-section list 1 2) 3 4))) + + +(test-group + "right-section" + + (test-equal '(3 4 2 1) + ((right-section list 1 2) 3 4))) + + +(test-group + "apply-chain" + (define cadr* (apply-chain car cdr)) + (define factorial ;;test multivalue + (apply-chain + * + (lambda (n) (apply values (cdr (iota (+ 1 n))))))) + + (test-equal 2 (cadr* (list 1 2 3))) + (test-equal 120 (factorial 5))) + + +(test-group + "arguments-drop" + + (test-equal + '(4) + ((arguments-drop list 3) 1 2 3 4))) + + +(test-group + "arguments-drop-right" + + (test-equal + '(1) + ((arguments-drop-right list 3) 1 2 3 4))) + + +(test-group + "arguments-take" + + (test-equal + '(1 2 3) + ((arguments-take list 3) 1 2 3 4))) + + +(test-group + "arguments-take-right" + + (test-equal + '(2 3 4) + ((arguments-take-right list 3) 1 2 3 4))) + + +(test-group + "group-by" + + (test-equal + '((1 3) + (2 4)) + ((group-by odd?) '(1 2 3 4))) + + (test-equal + '(("aa" "ab") + ("ba" "bb")) + ((group-by (lambda (str) (string-ref str 0)) + char=?) + (list "aa" "ba" "bb" "ab")))) + + +(test-group + "begin-procedure" + + (test-equal 2 + (begin-procedure + (lambda () 1) + (lambda () 2)))) + + +(test-group + "if-procedure" + + (test-equal 1 + (if-procedure #t + (lambda () 1) + (lambda () (test-assert #f)))) + + (test-equal 2 + (if-procedure #f + (lambda () (test-assert #f)) + (lambda () 2)))) + + +(test-group + "when-procedure" + + (define lst1 '()) + (define lst2 '()) + + (when-procedure #t + (lambda () (set! lst1 (cons 1 lst1))) + (lambda () (set! lst1 (cons 2 lst1)))) + + (when-procedure #f + (lambda () (set! lst2 (cons 1 lst2))) + (lambda () (set! lst2 (cons 2 lst2)))) + + (test-equal '(2 1) lst1) + (test-equal '() lst2)) + + +(test-group + "unless-procedure" + + (define lst1 '()) + (define lst2 '()) + + (unless-procedure #t + (lambda () (set! lst1 (cons 1 lst1))) + (lambda () (set! lst1 (cons 2 lst1)))) + + (unless-procedure #f + (lambda () (set! lst2 (cons 1 lst2))) + (lambda () (set! lst2 (cons 2 lst2)))) + + (test-equal '() lst1) + (test-equal '(2 1) lst2)) + + +(test-group + "value-procedure" + + (test-equal "1" + (value-procedure 1 + number->string + (lambda () (test-assert #f)))) + + (test-equal 2 + (value-procedure #f + (lambda args (test-assert #f)) + (lambda () 2)))) + + +(test-group + "case-procedure" + + (test-equal 2 + (case-procedure 'b + `((a . ,(lambda () 1)) + (b . ,(lambda () 2))))) + + (test-equal 3 + (case-procedure 'c + `((a . ,(lambda () 1)) + (b . ,(lambda () 2))) + (lambda () 3)))) + + +(test-group + "and-procedure" + + (test-assert + (and-procedure)) + + (test-equal 2 + (and-procedure (lambda () 1) + (lambda () 2))) + + (test-assert + (not (and-procedure (lambda () #f) + (lambda () (test-assert #f)))))) + + +(test-group + "eager-and-procedure" + + (test-assert + (eager-and-procedure)) + + (test-equal 2 + (eager-and-procedure (lambda () 1) + (lambda () 2))) + + (let ((second-called? #f)) + (test-assert + (not (eager-and-procedure (lambda () #f) + (lambda () + (set! second-called? #t) + #t)))) + (test-assert second-called?))) + + +(test-group + "or-procedure" + + (test-assert + (not (or-procedure))) + + (test-equal 2 + (or-procedure (lambda () #f) + (lambda () 2))) + + (test-assert + (or-procedure (lambda () 1) + (lambda () (test-assert #f))))) + + +(test-group + "eager-or-procedure" + + (test-assert + (not (eager-or-procedure))) + + (test-equal 2 + (eager-or-procedure (lambda () #f) + (lambda () 2))) + + (let ((second-called? #f)) + (test-equal 1 + (eager-or-procedure (lambda () 1) + (lambda () + (set! second-called? #t) + #f))) + (test-assert second-called?))) + +(test-group + "funcall-procedure" + + (test-equal 1 + (funcall-procedure (lambda () 1)))) + +(test-group + "loop-procedure" + + (call/cc (lambda (k) + (define v 0) + (define (thunk) + (when (> v 5) + (k #t)) + (set! v (+ 1 v))) + (loop-procedure thunk) + (test-assert #t)))) + + +(test-group + "while-procedure" + + (define v 0) + (define (thunk) + (set! v (+ 1 v)) + (< v 5)) + (while-procedure thunk) + (test-equal 5 v)) + + +(test-group + "until-procedure" + + (define v 0) + (define (thunk) + (set! v (+ 1 v)) + (>= v 5)) + (until-procedure thunk) + (test-equal 5 v)) + + +(test-group + "always" + + (test-assert (always)) + (test-assert (always 'a))) + + +(test-group + "never" + + (test-assert (not (never))) + (test-assert (not (never 'a)))) + + + +(test-group + "boolean" + + (test-equal #t (boolean 1)) + (test-equal #f (boolean #f))) + + +(test-group + "values" + + (test-equal 1 (values 1)) + (test-equal 'a (values 'a))) + + +(test-end) -- 2.45.1