;;
;; chicken-sdl2: CHICKEN Scheme bindings to Simple DirectMedia Layer 2
;;
;; Copyright © 2013–2021  John Croisant.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; - Redistributions of source code must retain the above copyright
;;   notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;;   notice, this list of conditions and the following disclaimer in
;;   the documentation and/or other materials provided with the
;;   distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
;; OF THE POSSIBILITY OF SUCH DAMAGE.


;; Macro: define-enum-mappings
;;
;; Defines and exports a group of related integer constants, plus
;; defines (but does not export) procedures to convert them to or
;; from user-friendly symbols.
;;
;; The constants should be semantically related, and each integer
;; value should be unique within the group (unless it is marked with
;; the duplicate flag). They do not need to be a true enum in C.
;;
;; Basic usage:
;;
;;   (define-enum-mappings
;;     type: FOREIGN-TYPE
;;     symbol->value: SYMBOL->VALUE
;;     value->symbol: VALUE->SYMBOL
;;     ((SYMBOL CONSTANT [FLAG ...])
;;      ...))
;;
;; You can optionally mark multiple lists of constants with a feature
;; ID and a C preprocessor condition, such as:
;;
;;   (required: libSDL-2.0.1+ "SDL_VERSION_ATLEAST(2,0,1)")
;;
;; In such cases those constants will be omitted if the feature is
;; available to cond-expand, and the preprocessor condition is true.
;;
;; Advanced usage:
;;
;;   (define-enum-mappings
;;     type: FOREIGN-TYPE
;;     symbol->value: SYMBOL->VALUE
;;     value->symbol: VALUE->SYMBOL
;;     ((required: FEATURE-ID C-PREPROCESS)
;;      (SYMBOL CONSTANT [FLAG ...])
;;      ...)
;;     ...)
;;
;; FOREIGN-TYPE must be an existing foreign type specifier that
;; applies to all the constants' integer values.
;;
;; SYMBOL->VALUE is the name for a procedure to convert from a symbol
;; to the corresponding integer value. The procedure will be defined
;; by this macro. The procedure will have one required argument, a
;; symbol, and one optional argument, a procedure that will be called
;; if the conversion fails (this can be used to throw an error or
;; return a default value).
;;
;; VALUE->SYMBOL is the name for a procedure to convert from an
;; integer value to the corresponding symbol. The procedure will be
;; defined by this macro. The procedure will have one required
;; argument, an integer value, and one optional argument, a procedure
;; that will be called if the conversion fails (this can be used to
;; throw an error or return a default value).
;;
;; FEATURE-ID is an unquoted Scheme symbol that is a feature usable
;; with cond-expand.
;;
;; C-PREPROCESS is a string with a C preprocessor condition, which
;; must be valid in the C code `#if C-PREPROCESS`.
;;
;; Each (SYMBOL CONSTANT [FLAG ...]) list defines a mapping between
;; an integer constant and a user-friendly symbol.
;;
;; - SYMBOL is an unquoted symbol that users will use instead of the
;;   integer constant. It should be lowercase and hyphen-separated.
;;
;; - CONSTANT is the name (as an unquoted symbol) of an integer
;;   constant or enum value, exactly as it appears in C. This will
;;   also be the name of the constant definition in Scheme.
;;
;; - FLAGs are optional unquoted symbols marking the constant as special:
;;
;;   - `duplicate`: The integer constant is an alias for another
;;      integer constant. It is omitted from VALUE->SYMBOL to avoid a
;;      C compiler error about "duplicate case value".
;;
;; Examples:
;;
;;   ;; Basic usage
;;   (define-enum-mappings
;;     type: Uint32
;;     symbol->value: symbol->foo
;;     value->symbol: foo->symbol
;;
;;     ((foo  SDL_FOO)
;;      (bar  SDL_BAR  duplicate)
;;      (baz  SDL_BAZ)))
;;
;;   ;; Advanced usage
;;   (define-enum-mappings
;;     type: Uint32
;;     symbol->value: symbol->foo
;;     value->symbol: foo->symbol
;;
;;     ((required: libSDL-2.0.0+ "SDL_VERSION_ATLEAST(2,0,0)")
;;      (foo  SDL_FOO)
;;      (bar  SDL_BAR  duplicate))
;;     ((required: libSDL-2.0.1+ "SDL_VERSION_ATLEAST(2,0,1)")
;;      (baz  SDL_BAZ)))
;;
(define-syntax define-enum-mappings
  (syntax-rules (type: value->symbol: symbol->value:)
    ((define-enum-mappings
       type: FOREIGN-TYPE
       symbol->value: SYMBOL->VALUE
       value->symbol: VALUE->SYMBOL
       (BRANCH ...)
       ...)
     (begin
       (define-enum-constants
         type: FOREIGN-TYPE
         (BRANCH ...)
         ...)

       (define-enum-symbol->value SYMBOL->VALUE
         (BRANCH ...)
         ...)

       (define-enum-value->symbol VALUE->SYMBOL
         type: FOREIGN-TYPE
         (BRANCH ...)
         ...)))))


(define-syntax define-enum-constants
  (syntax-rules (type: required:)
    ;; Basic usage
    ((define-enum-constants
       type: FOREIGN-TYPE
       ((SYMBOL CONSTANT . MAYBE-FLAGS)
        ...))
     (define-foreign-constants FOREIGN-TYPE CONSTANT ...))

    ;; Advanced usage
    ((define-enum-constants
       type: FOREIGN-TYPE
       ((required: FEATURE-ID C-PREPROCESS)
        (SYMBOL CONSTANT . MAYBE-FLAGS)
        ...)
       ...)
     (begin
       (cond-expand
        (FEATURE-ID
         (define-foreign-constants FOREIGN-TYPE CONSTANT ...))
        (else))
       ...))))


(define-syntax define-enum-symbol->value
  (syntax-rules (required:)
    ;; Basic usage
    ((define-enum-symbol->value SYMBOL->VALUE
       ((SYMBOL CONSTANT . MAYBE-FLAGS)
        ...))
     (define (SYMBOL->VALUE symbol #!optional not-found-callback)
       (case symbol
         ((SYMBOL) CONSTANT)
         ...
         (else
          (if not-found-callback
              (not-found-callback symbol)
              (error "invalid enum symbol" symbol))))))

    ;; Advanced usage
    ((define-enum-symbol->value SYMBOL->VALUE
       ((required: FEATURE-ID C-PREPROCESS)
        (SYMBOL CONSTANT . MAYBE-FLAGS)
        ...)
       ...)
     (define (SYMBOL->VALUE symbol #!optional not-found-callback)
       (call-with-current-continuation
        (lambda (return)
          (cond-expand
           (FEATURE-ID
            (case symbol
              ((SYMBOL) (return CONSTANT))
              ...))
           (else))
          ...
          (if not-found-callback
              (not-found-callback symbol)
              (error "invalid enum symbol" symbol))))))))


(define-syntax define-enum-value->symbol
  (syntax-rules (type: required:)
    ;; Basic usage
    ((define-enum-value->symbol VALUE->SYMBOL
       type: FOREIGN-TYPE
       ((required: FEATURE-ID C-PREPROCESS)
        (SYMBOL CONSTANT . MAYBE-FLAGS)
        ...)
       ...)
     (define (VALUE->SYMBOL value #!optional not-found-callback)
       (define foreign
         (%enum-value->symbol
          FOREIGN-TYPE
          (C-PREPROCESS
           (SYMBOL CONSTANT . MAYBE-FLAGS)
           ...)
          ...))
       (let ((symbol (foreign value)))
         (cond (symbol symbol)
               (not-found-callback (not-found-callback value))
               (else (error "invalid enum value" value))))))

    ;; Advanced usage
    ((define-enum-value->symbol VALUE->SYMBOL
       type: FOREIGN-TYPE
       ((SYMBOL CONSTANT . MAYBE-FLAGS)
        ...))
     (define-enum-value->symbol VALUE->SYMBOL
       type: FOREIGN-TYPE
       ((required: any "1")
        (SYMBOL CONSTANT . MAYBE-FLAGS)
        ...)))))


;; Usage:
;;
;;   (%enum-value->symbol
;;    FOREIGN-TYPE
;;    ("C-PREPROCESS"
;;     (SYMBOL CONSTANT [FLAG ...])
;;     ...)
;;    ...)
;;
;; Expands to something like:
;;
;;   (foreign-primitive
;;    ((FOREIGN-TYPE x))
;;    "C_word av[2+1] = {C_SCHEME_UNDEFINED, C_k, C_SCHEME_FALSE};"
;;    "C_word* a;"
;;    "switch(x) {"
;;    "#if C-PREPROCESS
;;    "case CONSTANT:
;;      a = C_alloc(C_SIZEOF_INTERNED_SYMBOL(sizeof(\"SYMBOL\")));
;;      av[2+1-1] = C_intern2(&a, \"SYMBOL\");
;;      break;
;;    }"
;;    ...
;;    "#endif"
;;    ...
;;    "C_values(2+1, av);")
;;
;; This allocates and returns an interned symbol based on which case
;; of the switch statement matches. If no case matches, it returns #f.
;;
(define-syntax %enum-value->symbol
  (ir-macro-transformer
   (lambda (form inject compare?)
     (define (feature-branch C-PREPROCESS . SYMBOL-CONSTS)
       (append
        (list (string-append "\n#if " C-PREPROCESS "\n"))
        (map (lambda (sym-con-flags)
               (apply enum-branch sym-con-flags))
             (map (lambda (sym-const)
                    (map strip-syntax sym-const))
                  SYMBOL-CONSTS))
        (list "\n#endif\n")))

     (define (enum-branch SYMBOL CONSTANT . FLAGS)
       (cond
        ;; Omit duplicates to avoid "duplicate case value" C errors.
        ((memq 'duplicate FLAGS)
         "")
        (else
         (sprintf
          "case ~A:
             a = C_alloc(C_SIZEOF_INTERNED_SYMBOL(sizeof(\"~A\")));
             av[2+1-1] = C_intern2(&a, \"~A\");
             break;"
          CONSTANT SYMBOL SYMBOL))))

     (let ((FOREIGN-TYPE (list-ref form 1))
           (branches (cddr form)))
       `(foreign-primitive
         ((,(strip-syntax FOREIGN-TYPE) x))
         "C_word av[2+1] = {C_SCHEME_UNDEFINED, C_k, C_SCHEME_FALSE};"
         "C_word* a;"
         "switch(x) {"
         ,@(apply append
             (map (lambda (branch) (apply feature-branch branch))
                  branches))
         "}"
         "C_values(2+1, av);")))))