lisp/syntax/functional.scm

   1 ;;; functional.scm ---
   2
   3 ;; Copyright (C) 2014  <Dmitry Bogatov <KAction@gnu.org>>
   4
   5 ;; Author:  <Dmitry Bogatov <KAction@gnu.org>>
   6
   7 ;; This program is free software; you can redistribute it and/or
   8 ;; modify it under the terms of the GNU General Public License
   9 ;; as published by the Free Software Foundation; either version 3
  10 ;; of the License, or (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;;; Code:
  23 (define-module (syntax functional)
  24   #:export (syntax-fold
  25             syntax-fold-right
  26             syntax-cons
  27             syntax-xcons
  28             syntax-map
  29             syntax-map*
  30             syntax-car
  31             syntax-begin
  32             unsyntax-keywords))
  33 (use-modules (syntax implicit))
  34 (use-modules (srfi srfi-1))
  35 ;; TODO: Generalize on any amount of lists
  36 (define (syntax-fold fn init list)
  37   (syntax-case list ()
  38     [() init]
  39     [(val rest ...) (syntax-fold fn (fn #'val init) #'(rest ...))]))
  40
  41 (define (syntax-fold-right fn init list)
  42   (syntax-case list ()
  43     [() init]
  44     [(val rest ...) (fn #'val (syntax-fold-right fn init #'(rest ...)))]))
  45
  46 (define (syntax-cons x y)
  47   (with-syntax ((x x))
  48     (syntax-case y ()
  49       [obj #'(x . obj)])))
  50
  51 (define (syntax-xcons x y)
  52   (syntax-cons y x))
  53
  54 (define-transformer (syntax-car)
  55   [(car . rest) #'car])
  56
  57 (define (syntax-map transformer syntax)
  58   (syntax-fold-right
  59    (lambda (el acc) (syntax-cons (transformer el) acc))
  60    '() syntax))
  61
  62 (define (syntax-map* transformer syntax)
  63   (syntax-fold-right cons '() syntax))
  64
  65 (define (significant? x)
  66     (not (or (eq? x *unspecified*)
  67              (eq? x #f))))
  68
  69 (define (syntax-begin . args)
  70   (syntax-xcons
  71    (fold-right syntax-cons '()
  72                (filter significant? args))
  73    #'begin))
  74
  75 (define-transformer (unsyntax-keywords)
  76   [() '()]
  77   [(key value rest ...)
  78    (let ((key (syntax->datum #'key)))
  79      (unless (keyword? key)
  80        (syntax-violation 'unsyntax-keywords
  81                          "expected keyword as car" %syntax))
  82      (append (list key #'value)
  83              (unsyntax-keywords #'(rest ...))))])