scheme-gnunet/gnu/extractor/enum.scm

;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet
;;   scheme-GNUnet contains scheme-extractor.
;;   scheme-extractor is a partial Scheme port of libextractor.
;;   Copyright (C) 2020, 2021 GNUnet e.V.
;;   SPDX-License-Identifier: GPL-3.0-or-later
;;
;;   libextractor is free software; you can redistribute it and/or modify
;;   it under the terms of the GNU General Public License as published
;;   by the Free Software Foundation; either version 3, or (at your
;;   option) any later version.
;;
;;   libextractor is distributed in the hope that it will be useful, but
;;   WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;   General Public License for more details.
;;
;;   You should have received a copy of the GNU General Public License
;;   along with libextractor; see the file COPYING.  If not, write to the
;;   Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;   Boston, MA 02110-1301, USA.

;; Brief: typed C-like enums
;; Features:
;;  * typed
;;  * integer and symbol conversion
;;  * source line information (bug: isn't registered for some reason)
;;  * docstrings
;;  * enum values can be compared with eq?
;;    (unless they aren't defined, in which
;;    one must compare the indices directly,
;;    or with value=?)

(define-library (gnu extractor enum)
  (export value->index value->symbol value-dynamic?
	  value-documentation value-source
	  value-enum
	  enum-name enum-max-value enum-predefined-values
	  enum-source enum-docstring
	  integer->value symbol->value symbol-value
	  value enumeration define-enumeration
	  value=?)
  (import (only (guile)
		write newline display
		syntax-source assq-ref compose
		resolve-module module-ref
		raise-exception)
	  (only (system syntax) syntax-local-binding)
	  (system vm program)
	  (ice-9 format)
	  (only (srfi srfi-9 gnu)
		set-record-type-printer!)
	  (except (srfi srfi-1) map)
	  (srfi srfi-26)
	  (except (srfi srfi-43) vector-map)
	  (rnrs base)
	  ;;map vector-map)
	  (rnrs control)
	  (rnrs syntax-case)
	  (rnrs records syntactic))
  (begin
    (define-record-type (<value> %make-value value?)
      ;; Numeric value
      (fields (immutable index     value->index)
	      ;; Symbolic name (or #f)
       	      (immutable symbol    value->symbol)
	      ;; Is this predefined (so eq? can be used),
	      ;; or dynamically generated (so equal? must be used)?
	      (immutable dynamic?  value-dynamic?)
	      ;; Docstring (or #f)
	      (immutable docstring value-documentation)
	      ;; thunked <enum>
	      (immutable part-of   value-enum-thunk)
	      ;; Source location (or #f)
	      (immutable source    value-source))
      (sealed #t)
      (opaque #t))

    (define (value=? x y)
      "Compare two values of the same enumeration."
      (assert (eq? ((value-enum-thunk x))
		   ((value-enum-thunk y))))
      (= (value->index x)
	 (value->index y)))

    (define (value-enum enum)
      "To which enumeration does @var{enum} belong?"
      (let ((t (value-enum-thunk enum)))
	(if t (t) #f)))

    ;; FIXME variant if enum is sparse
    (define-record-type (<enum> %make-enum enum?)
      (fields (immutable max    enum-max-value)
	      (immutable symbol enum-name)
	      (immutable values enum-predefined-values)
	      (immutable source enum-source)
	      (immutable docstring enum-docstring))
      (sealed #t)
      (opaque #t))

    ;; Make sure record printing terminates.
    ;; Also include line numbers, and remove
    ;; uninteresting data (and data that takes
    ;; too much space).
    (set-record-type-printer!
     <value>
     (lambda (record port)
       (let ((sources (value-source record)))
	 (if sources
	     ;; TODO source:[...] + syntax-source isn't correct,
	     ;; at least on Guile 3.0.7, though no exception will result.
	     (format port "#<value (~a ~a) index: ~a at ~a:~a:~a>"
		     (enum-name ((value-enum-thunk record)))
		     (value->symbol record)
		     (value->index record)
		     (source:file sources)
		     (source:line sources)
		     (source:column sources))
	     (format port "#<value (~a ~a) index: ~a>"
		     (enum-name ((value-enum-thunk record)))
		     (value->symbol record)
		     (value->index record))))))

    (set-record-type-printer!
     <enum>
     (lambda (record port)
       (let ((sources (enum-source record)))
	 (if sources
	     (format port "#<enum ~a (max: ~a) at ~a:~a:~a>"
		     (enum-name record)
		     (enum-max-value record)
		     (source:file sources)
		     (source:line sources)
		     (source:column sources))
	     (format port "<enum ~a (max: ~a)>"
		     (enum-name record)
		     (enum-max-value record))))))

    (define (%make-enum/fix max symbol values-proc source docstring)
      (letrec ((e (%make-enum max symbol
			      (vector-map (lambda (vproc)
					    (vproc (lambda () e)))
					  values-proc)
			      source docstring)))
	e))

    (define (integer->value enum i)
      (assert (and (exact? i) (integer? i)))
      (assert (<= 0 i))
      (assert (<= i (enum-max-value enum)))
      (let ((predef (enum-predefined-values enum)))
	(if (< i (vector-length predef))
	    (vector-ref predef i)
	    (%make-value i #f #t #f (lambda () enum) #f))))

    ;; Slow
    (define (symbol->value enum s)
      "Return the enum value in @var{enum} with symbol @var{s},
or #f it doesn't exist."
      (let ((i (vector-index (compose (cute eq? s <>) value->symbol)
			     (enum-predefined-values enum))))
	(and i (vector-ref (enum-predefined-values enum) i))))

    ;; Returned code is fast.
    (define-syntax symbol-value
      (lambda (x)
	"Takes a (name of) a enumeration @var{enum} and literal symbol
@var{s} in that, and expands to an expression returning the enumeration
value. Due to technical reasons, @var{enum} must be a binding from a
module, and @var{enum} must be defined the same in the build and host."
	(syntax-case x ()
	  ((_ enum s)
	   (let-values (((type info) (syntax-local-binding #'enum)))
	     (case type
	       ((global)
		(let* ((module (resolve-module (cdr info)))
		       (enum@host (module-ref module (car info)))
		       (value@host (symbol->value enum@host
						  (syntax->datum #'s)))
		       (index (value->index value@host)))
		  #`(vector-ref (enum-predefined-values enum) #,index)))
	       (else (raise-exception
		      (syntax-violation 'symbol-value
					"@var{enum} is not a global variable"
					x
					#'enum)))))))))

    (define (syntax->list s)
      (syntax-case s ()
	(() '())
	((x . rest)
	 (cons #'x (syntax->list #'rest)))))

    (define-syntax value
      (lambda (s)
	(syntax-case s ()
	  ((_ (x y) ...)
	   (let* ((key-value
		   (zip (map syntax->datum (syntax->list #'(x ...)))
			(syntax->list #'(y ...))))
		  (index/syntax (assq-ref key-value 'index))
		  (index (car (syntax->datum index/syntax)))
		  (symbol/syntax (assq-ref key-value 'symbol))
		  (symbol (if symbol/syntax
			      (car (syntax->datum symbol/syntax))
			      #f))
		  (docstring/syntax
		   (assq-ref key-value 'documentation))
		  (docstring (if docstring/syntax
				 (car (syntax->datum docstring/syntax))
				 #f)))
	     (assert (and (exact? index) (integer? index)))
	     (when symbol
	       (assert (symbol? symbol)))
	     (when docstring
	       (assert (string? docstring)))
	     #`(lambda (thunk)
		 (%make-value #,index
			      '#,(datum->syntax s symbol)
			      #f
			      #,docstring
			      thunk
			      '#,(datum->syntax #f (syntax-source s)))))))))

    ;; TODO verify indices are correct
    (define-syntax enumeration
      (lambda (s)
	(syntax-case s ()
	  ((_ (name)
	      (#:documentation doc)
	      (#:max maximum)
	      (#:known entry ...))
	   #`(%make-enum/fix 'maximum
			     'name
			     (vector entry ...)
			     '#,(datum->syntax #f (syntax-source s))
			     doc)))))

    (define-syntax define-enumeration
      (syntax-rules ()
	((_ (name enum-value?)
	    (#:documentation doc)
	    (#:max maximum)
	    (#:known entry ...))
	 (begin
	   (define name
	     (enumeration (name)
			  (#:documentation doc)
			  (#:max maximum)
			  (#:known entry ...)))
	   (define (enum-value? o)
	     (and (value? o)
		  (eq? name ((value-enum-thunk o)))))))))))