[gnunet-scheme] 55/324: enum: implement docstrings and general niceness

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a commit to branch master
in repository gnunet-scheme.

commit c7fb58ed3faf821d514f596ca1e737657b2e93b6
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Wed Jan 27 19:55:54 2021 +0100

    enum: implement docstrings and general niceness
    
    This breaks the libextractor port, and directory creation
    -- will be fixed later. The new enumeration module supports
    defining docstrings, (untested) source line numbers and
    symbol<->typed value<->integer conversion.
    
    Somthing to do later: rename gnu/extractor/enum.scm to
    something else.
    
    * gnu/extractor/enum.scm: rewrite
---
 gnu/extractor/enum.scm | 257 +++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 227 insertions(+), 30 deletions(-)

diff --git a/gnu/extractor/enum.scm b/gnu/extractor/enum.scm
index d3af6a7..0f0498c 100644
--- a/gnu/extractor/enum.scm
+++ b/gnu/extractor/enum.scm
@@ -1,7 +1,7 @@
 ;;   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 Maxime Devos
+;;   Copyright (C) 2020, 2021 Maxime Devos
 ;;
 ;;   libextractor is free software; you can redistribute it and/or modify
 ;;   it under the terms of the GNU General Public License as published
@@ -19,33 +19,230 @@
 ;;   Boston, MA 02110-1301, USA.
 
 ;; Brief: typed C-like enums
-;; TODO: pretty-printing and debugging information
-;; Note: this is an internal module, subject to change
-(library (gnu extractor enum)
-  (export define-wrapped-enum)
-  (import (rnrs base)
+;; 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))
-  (define-syntax define-wrapped-enum
-    (syntax-rules (#;max #;known)
-      ((_ (<wrapped> wrapped? integer-> ->integer)
-         (#:max maximum)
-         (#:known (name value) ...))
-       (begin
-        (define-record-type (<wrapped> %make-wrapped wrapped?)
-          (fields (immutable unwrapped ->integer))
-          (sealed #t)
-          (opaque #t))
-
-        (define (integer-> index)
-          ;; TODO: more descriptive exceptions
-          (assert (and (exact? index) (integer? index)))
-          (assert (and (<= 0 index) (<= index maximum)))
-          (%make-wrapped index))
-
-        ;; Warning: this may be defined as syntax in the future!
-        ;; (equal? <wrapped> are not necessarily eq?,
-        ;; and a fresh <wrapped> may be generated each time).
-        ;;
-        ;; TODO: verify integer-hood at compile-time
-        (define name (integer-> value))
-        ...)))))
+  (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
+            (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)))
+      (if (< i (enum-max-value enum))
+         (vector-ref (enum-predefined-values enum) i)
+         (%make-value i #f #t #f #f #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))))
+       (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
+                             #,(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 ...)
+                            #,(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)))))))))))

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.