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 ;; This module defines functions to operate on syntax objects similar
  22 ;; to common function operations saving referential transparency.
  23
  24 ;;; Code:
  25 (define-module (syntax functional))
  26
  27 (use-modules (srfi srfi-1))
  28 (use-modules (ice-9 match))
  29 (use-modules (ice-9 control))
  30
  31 (define-syntax sealed (const #'#f))
  32 (eval-when (compile)
  33   (let ((thales-module (resolve-module '(thales seal) #:ensure #f)))
  34     (if thales-module
  35         (module-define! (current-module) 'sealed
  36           (module-ref thales-module 'sealed))
  37         (format #t "~a\n~a\n"
  38                 "Module (thales seal) is not available."
  39                 "GNU Thales based testing is disabled."))))
  40
  41 (sealed s-car
  42   (#'(foo bar) *#* foo)
  43   (#'(foo) *#* foo)
  44   (#'() *!* syntax-error))
  45
  46 (define-public (s-car x)
  47   (syntax-case x ()
  48     ((car . cdr) #'car)))
  49
  50 (sealed s-cdr
  51   (#'(foo bar) *#* (bar))
  52   (#'(foo) *#* ()))
  53
  54 (define-public (s-cdr x)
  55   (syntax-case x ()
  56     ((car . cdr) #'cdr)))
  57
  58 (sealed s-cons
  59   (#'x #'y *#* (x . y))
  60   (#'x #'y #'z *!* wrong-number-of-args))
  61
  62 (define-public (s-cons x y)
  63   #`(#,x . #,y))
  64
  65 (define-public (s-xcons x y)
  66   (s-cons y x))
  67
  68 (sealed s-null?
  69   (#'(foo) *** #f)
  70   (#'() *** #t))
  71
  72 (define (s-null? x)
  73   (equal? x #'()))
  74
  75 (define-public (s-fold fn init list1 . more)
  76   ;; One more line to make explicit in signature
  77   ;; that at least one list must be present.
  78   (let ((lists (cons list1 more)))
  79     (if (any s-null? lists)
  80         init
  81         (let* ((vals (map s-car lists))
  82                (tails (map s-cdr lists))
  83                (args `(,@vals ,init)))
  84           (apply s-fold fn (apply fn args) tails)))))
  85
  86 (define-public (s-fold-right fn init list1 . more)
  87   ;; One more line to make explicit in signature
  88   ;; that at least one list must be present.
  89   (let ((lists (cons list1 more)))
  90     (if (any s-null? lists)
  91         init
  92         (let ((vals (map s-car lists))
  93               (tails (map s-cdr lists)))
  94           (apply fn `(,@vals ,(apply s-fold-right fn init tails)))))))
  95
  96 (sealed s-list
  97   (*#* ())
  98   (#'x *#* (x))
  99   (#'foo #'bar *#* (foo bar)))
 100
 101 (define-public (s-list . args)
 102   (s-fold-right s-cons #'() args))
 103
 104 (sealed s-reverse
 105         (#'(foo bar) *#* (bar foo)))
 106
 107 (define-public (s-reverse x)
 108   (s-fold s-cons #'() x))
 109
 110 (sealed s-map-in-order
 111   (s-car #'((foo bar) (qq quaz)) *#* (foo qq)))
 112
 113 (define-public (s-map-in-order f list1 . more)
 114   (s-reverse (apply s-fold
 115                     (match-lambda*
 116                      ((args ... acc) (s-cons (apply f args) acc)))
 117                     #'() list1 more)))
 118
 119 (define-public s-map s-map-in-order)
 120
 121 (sealed s-filter
 122   (identifier? #'(foo (bar oo)) *#* (foo)))
 123
 124 (define-public (s-filter p list)
 125   (syntax-case list ()
 126     (() #'())
 127     ((car . cdr)
 128      (let ((filtered-tail (s-filter p #'cdr)))
 129        (if (p #'car)
 130            (s-cons #'car filtered-tail)
 131            filtered-tail)))))
 132
 133 (sealed s-begin
 134   (#f #'foo #'bar *#* (begin foo bar)))
 135
 136 (define-public (s-begin . args)
 137   (define (significant? x)
 138     (and x (not (eq? x *unspecified*))))
 139   (s-cons #'begin (s-filter significant? args)))
 140
 141
 142 ;; FIXME: Write seals.
 143 (define-public (s->if-datum pred? list)
 144   (s-fold-right
 145    (lambda (x acc)
 146      (define datum (syntax->datum x))
 147      (xcons acc (if (pred? datum) datum x)))
 148    '()
 149    list))