guile-rsv

R7RS Scheme library for reading and writing RSV (Rows of String Values) data format. Specified in https://github.com/Stenway/RSV-Specification and demonstrated in https://www.youtube.com/watch?v=tb_70o6ohMA
git clone https://kaka.farm/~git/guile-rsv
Log | Files | Refs | README | LICENSE

commands.scm (4618B)

      1 ;;; Scheme implementation of RSV - Rows of String Values.
      2 ;;; Copyright (C) 2024  Yuval Langer.
      3 ;;;
      4 ;;; This program is free software: you can redistribute it and/or modify
      5 ;;; it under the terms of the GNU General Public License as published by
      6 ;;; the Free Software Foundation, either version 3 of the License, or
      7 ;;; (at your option) any later version.
      8 ;;;
      9 ;;; This program is distributed in the hope that it will be useful,
     10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     12 ;;; GNU General Public License for more details.
     13 ;;;
     14 ;;; You should have received a copy of the GNU General Public License
     15 ;;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
     16 
     17 (define-library (rsv commands)
     18   (import (scheme base)
     19           (scheme cxr)
     20           (scheme file)
     21           (scheme read)
     22           (scheme write)
     23 
     24           (srfi srfi-28)
     25           (srfi srfi-41)
     26           
     27           (rsv)
     28           (rsv rows-streams)
     29           (rsv version))
     30   (export run-main
     31           rsv2scm
     32           rsv2scm-stream
     33           scm2rsv)
     34 
     35   (begin
     36     (define (display-help args)
     37       (let ((arg0 (car args)))
     38         (display (format "Usage: ~a [OPTIONS]...
     39 
     40 Keywords:
     41   -h,  --help     Print this help message.
     42   -V,  --version  Display the version and exit.
     43 
     44 Send bug reports and questions to <yuval.langer@gmail.com>.
     45 " arg0))))
     46 
     47     (define (display-version args)
     48       (let ((arg0 (car args)))
     49         (display (format "~a version ~a
     50 Copyright (C) 2024  Yuval Langer
     51 License GPLv3+: GNU GPL version 3 or later
     52 <http://www.gnu.org/licenses/gpl.html>.
     53 This is free software: you are free to change and redistribute it.
     54 There is NO WARRANTY, to the extent permitted by law.
     55 " arg0 version))))
     56 
     57     (define (scm2rsv maybe-filename)
     58       (write-rsv (read (file-or-current-input-port maybe-filename))
     59                  (current-output-port)))
     60 
     61     (define (file-or-current-input-port maybe-filename)
     62       (cond
     63        ((null? maybe-filename)
     64         (current-input-port))
     65        (else
     66         (open-input-file (car maybe-filename)))))
     67 
     68     (define (rsv2scm-stream maybe-filename)
     69       (let ((stream (port->rsv-row-stream (file-or-current-input-port maybe-filename))))
     70         (let loop ((stream stream))
     71           (cond
     72            ((stream-null? stream)
     73             '())
     74            (else
     75             (let ((row (stream-car stream)))
     76               (write row)
     77               (newline)
     78               (loop (stream-cdr stream))))))))
     79 
     80     (define (rsv2scm maybe-filename)
     81       (write (read-rsv (file-or-current-input-port maybe-filename)))
     82       (newline))
     83 
     84     (define (run-main args command)
     85       (let ((args-length (length args)))
     86         (cond
     87          ((= args-length 1)
     88           (cond
     89            ((eq? 'rsv2scm command)
     90             (rsv2scm '()))
     91            ((eq? 'scm2rsv command)
     92             (scm2rsv '()))))
     93          ((= args-length 2)
     94           (let ((option (cadr args)))
     95             (cond
     96              ((or (equal? option "-V")
     97                   (equal? option "--version"))
     98               (display-version args))
     99              ((or (equal? option "-h")
    100                   (equal? option "--help"))
    101               (display-help args))
    102              ((or (equal? option "-s")
    103                   (equal? option "--stream"))
    104               (cond
    105                ((eq? 'rsv2scm command)
    106                 (rsv2scm-stream '()))
    107                (else
    108                 (error "No stream option for:"
    109                        (car args)))))
    110              ((eq? 'rsv2scm command)
    111               (rsv2scm (list option)))
    112              ((eq? 'scm2rsv command)
    113               (scm2rsv (list option)))
    114              (else
    115               (error "Unknown commands:"
    116                      (cdr args))))))
    117          ((= args-length 3)
    118           (let ((option (cadr args))
    119                 (filename (caddr args)))
    120             (cond
    121              ((or (equal? option "-V")
    122                   (equal? option "--version"))
    123               (display-version args))
    124              ((or (equal? option "-h")
    125                   (equal? option "--help"))
    126               (display-help args))
    127              ((or (equal? option "-s")
    128                   (equal? option "--stream"))
    129               (cond
    130                ((eq? 'rsv2scm command)
    131                 (rsv2scm-stream (list filename)))
    132                (else
    133                 (error "No stream option for:"
    134                        (car args)))))
    135              (else
    136               (error "Unknown commands:"
    137                      (cdr args))))))
    138          (else
    139           (error "Command does not accept more than one option.")))))))