module/mes/misc.scm

   1 ;;; GNU Mes --- Maxwell Equations of Software
   2 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Mes.
   5 ;;;
   6 ;;; GNU Mes is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Mes is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (mes misc)
  20   #:use-module (srfi srfi-1)
  21   #:export (%scheme
  22             disjoin
  23             guile?
  24             mes?
  25             pk
  26             pke
  27             warn
  28             stderr
  29             string-substitute))
  30
  31 (cond-expand
  32  (mes
  33   (define %scheme "mes"))
  34  (guile
  35   (define %scheme "guile")))
  36
  37 (define guile? (equal? %scheme "guile"))
  38 (define mes? (equal? %scheme "mes"))
  39
  40 (define (logf port string . rest)
  41   (apply format (cons* port string rest))
  42   (force-output port)
  43   #t)
  44
  45 (define (stderr string . rest)
  46   (apply logf (cons* (current-error-port) string rest)))
  47
  48 (define (pk . stuff)
  49   (newline)
  50   (display ";;; ")
  51   (write stuff)
  52   (newline)
  53   (car (last-pair stuff)))
  54
  55 (define (pke . stuff)
  56   (display "\n" (current-error-port))
  57   (newline (current-error-port))
  58   (display ";;; " (current-error-port))
  59   (write stuff (current-error-port))
  60   (display "\n" (current-error-port))
  61   (car (last-pair stuff)))
  62
  63 (define warn pke)
  64
  65 (define (disjoin . predicates)
  66   (lambda (. arguments)
  67     (any (lambda (o) (apply o arguments)) predicates)))
  68
  69 (define (string-substitute string find replace)
  70   (let ((index (string-contains string find)))
  71     (if (not index) string
  72         (string-append
  73          (string-take string index)
  74          replace
  75          (string-substitute
  76           (string-drop string (+ index (string-length find)))
  77           find replace)))))