mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-29 06:20:30 +02:00
36ba0aa655
https://srfi.schemers.org/srfi-197/srfi-197.html * NEWS: mention SRFI 197 support. * am/bootstrap.am: Add srfi-197.scm. * module/srfi/srfi-197.scm: Convert to module. * test-suite/Makefile.am: Add srfi-197.sr64. * test-suite/tests/srfi-197.sr64: Renamed from srfi-197.test. * test-suite/tests/srfi-197.test: Port to Guile; rename to srfi-197.sr64.
216 lines
9.3 KiB
Scheme
216 lines
9.3 KiB
Scheme
;;;; srfi-197.scm --- SRFI 197: Pipeline Operators
|
|
|
|
;;;; 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.
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; This is an implementation of SRFI 197: Pipeline Operators taken from
|
|
;;; the reference implementation's srfi-197-syntax-case.scm.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-module (srfi srfi-197)
|
|
#:use-module ((scheme base) #:select (eof-object let-values))
|
|
#:use-module (srfi srfi-2)
|
|
#:export (chain chain-and chain-lambda chain-when nest nest-reverse))
|
|
|
|
(cond-expand-provide (current-module) '(srfi-197))
|
|
|
|
(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))))
|