#|[
Author: Juergen Lorenz
ju (at) jugilo (dot) de

Copyright (c) 2015-2020, Juergen Lorenz
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.

Neither the name of the author nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission. 

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
HOLDERS 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.
|#

; This is a variant of the datatype egg, written by Felix Winkelmann,
; which in turn is patterned after the datatype facility described in
; the classic "Essentials of programming languages" (EOPL) by Friedman,
; Wand and Haynes. It changes the names and syntax a little and adds
; abstract types as well.

; Algebraic types are implemented by messages, which are vectors tagged
; with a type- and a variant-key.  Destructuring of algebraic types can
; be done more or less with bind-case from the bindings egg.

; Abstract types hide the constructors of its implementing algebraic
; types like the corresponding language construct of ML.
;
; Note that algebraic-types can be destructured not only by the generic
; macro case-variant, but also by type-specific macros Type-case. The
; latter are generated together with the type.

(module messages (
  messages
  make-message
  message?
  message-of?
  message-key
  message-type
  message-data
  case-variant
  define-algebraic-type
  define-abstract-type
  )
  
  (import scheme
          (only bindings bind-case)
          (only (chicken keyword) keyword?)
          (only (chicken base) error print receive case-lambda)
          )

  (import-for-syntax (only (chicken keyword) keyword? string->keyword)
                     (only (chicken base) symbol-append)
                     )

;;; vector-implementation of messages
;;; =================================

;;; (make-message type-key key . args)
;;; ----------------------------------
(define (make-message type key . args)
  (vector type key (apply vector args)))

;;; (message? xpr)
;;; --------------
(define (message? xpr)
  (and (vector? xpr)
       (= 3 (vector-length xpr))
       (keyword? (vector-ref xpr 0))
       (keyword? (vector-ref xpr 1))
       (vector? (vector-ref xpr 2))))

;;; (message-type msg)
;;; ------------------
;;; returns the type key of the message
(define (message-type msg)
  (vector-ref msg 0))

;;; (message-key msg)
;;; -----------------
;;; returns the key of the message
(define (message-key msg)
  (vector-ref msg 1))

;;; (message-data msg)
;;; ------------------
;;; returns the data vector of the message
(define (message-data msg)
  (vector-ref msg 2))

;;;; functional vector implementation of messages
;;;; ============================================
;;
;;;; (make-message type-key key . args)
;;;; ----------------------------------
;(define (make-message type key . args)
;  (fvector type key (apply fvector args)))
;
;;;; (message? xpr)
;;;; --------------
;(define (message? xpr)
;  (and (fvector? xpr)
;       (= 3 (fvector-length xpr))
;       (keyword? (fvector-ref xpr 0))
;       (keyword? (fvector-ref xpr 1))
;       (fvector? (fvector-ref xpr 2))))
;
;;;; (message-type msg)
;;;; ------------------
;;;; returns the type key of the message
;(define (message-type msg)
;  (fvector-ref msg 0)) ;(msg 0))
;
;;;; (message-key msg)
;;;; -----------------
;;;; returns the key of the message
;(define (message-key msg)
;  (fvector-ref msg 1)) ;(msg 1))
;
;;;; (message-data msg)
;;;; ------------------
;;;; returns the data vector of the message
;(define (message-data msg)
;  (list->vector (caddr (fvector-data msg))))

;;; (message-of? type-key)
;;; ----------------------------
;;; returns a predicate which checks, if its only argument
;;; is a message of the given type-key
(define (message-of? name)
  (lambda (msg)
    (eq? (message-type msg) name)))

;;; (case-variant Child msg (key args . body) ....)
;;; -----------------------------------------------
;;; matches msg againes each variant (key args) in sequence
;;; and executes body of the first matching variant
(define-syntax case-variant
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((%_ (rename '_))
            (%<<< (rename '<<<))
            (%else (rename 'else))
            (%message? (rename 'message?))
            (%bind-case (rename 'bind-case))
            (type (cadr form))
            (xpr (caddr form))
            (variants (reverse (cdddr form))) ; to check for %else
            )
        (let ((type-key ;(symbol->keyword type))
                (string->keyword (symbol->string type)))
              (default (if (compare? (caar variants) %else)
                         (car variants)
                         '()))
              (variants (if (compare? (caar variants) %else)
                          (reverse (cdr variants))
                          (reverse variants))))
          (let ((variant-keys (map car variants))
                (variant-args (map cadr variants))
                (variant-bodies (map cddr variants))
                (default-body (if (null? default)
                                '()
                                (cdr default))))
`(,%bind-case (,%<<< ,type-key ,xpr ,%message?)
   ,@(map (lambda (k a bs)
            `((,type-key ,k ,a) ,@bs))
          variant-keys variant-args variant-bodies)
   ,@(if (null? default)
       '()
       `((,%_ ,@default-body))))))))))

;;; (define-algebraic-type Child Parent ..
;;;   (variant-key (a a? ...) ...)
;;;   | (variant-key (a a? ...) ... as as? ...)
;;;   ....)
;;; -------------------------------------------
;;; defines a selector routine, Child, which, when called with the #:?
;;; keyword returns the type predicate, when called with another
;;; keyword, returns the corresponding message-constructor.
;;; When Child is called with no argument, it returns information on the
;;; type.
;;; Note that rest arguments, as, as well as their checks
;;; are not parenthesized. 
;;; Moreover, a destructure macro, Child-case, is generated, which specializes
;;; case-variant.
(define-syntax define-algebraic-type
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((Child (cadr form))
            (Parent (if (symbol? (caddr form))
                      (caddr form)
                      #f))
            (variants (if (symbol? (caddr form))
                        (cdddr form)
                        (cddr form)))
            (%or (rename 'or))
            (%<<< (rename '<<<))
            (%let (rename 'let))
            (%and (rename 'and))
            (%xpr (rename 'xpr))
            (%key (rename 'key))
            (%case (rename 'case))
            (%else (rename 'else))
            (%error (rename 'error))
            (%begin (rename 'begin))
            (%define (rename 'define))
            (%lambda (rename 'lambda))
            (%case-lambda (rename 'case-lambda))
            (%case-variant (rename 'case-variant))
            (%message? (rename 'message?))
            (%list-of? (rename 'list-of?))
            (%make-message (rename 'make-message))
            (%message-of? (rename 'message-of?))

            (%define-syntax (rename 'define-syntax))
            (%er-macro-transformer (rename 'er-macro-transformer))
            (%xpr0 (rename 'xpr0))
            (%xpr1 (rename 'xpr1))
            (%xprs0 (rename 'xprs0))
            (%xprs1 (rename 'xprs1))
            )
        (let ((kChild ;(symbol->keyword Child))
                (string->keyword (symbol->string Child)))
              (Child-case (symbol-append Child '-case))
              (keys (map car variants))
              (xargs (map cdr variants))
              (dissect
                (lambda (key args)
                  (receive (fas vas)
                    ;(split-at-symbol args)
                    (let loop ((tail args) (head '()))
                      (cond
                        ((null? tail)
                         (values (reverse head) tail))
                        ((symbol? (car tail))
                         (values (reverse head) tail))
                        (else
                          (loop (cdr tail) (cons (car tail) head)))))
                    (values
                      (map car fas)
                      (if (null? vas) vas (car vas))
                      (map (lambda (f)
                             `(,%<<< '(,Child ,key) ,@f))
                           fas)
                      (if (null? vas)
                        vas
                        `(,%<<< '(,Child ,key)
                          ,(car vas)
                          ,@(map (lambda (v)
                                   `(,%list-of? ,v))
                                 (cdr vas))))))))
             )
`(,%begin
   (,%define ,Child
      (,%case-lambda
        (()
         ',(append
             `(,kChild)
             variants
             (if Parent
               ((eval Parent))
               '())))
        ((,%key)
         (,%case ,%key
           ((#:?)
            (,%lambda (,%xpr)
              (,%and (,%message? ,%xpr)
                     (,%or ((,%message-of?; ,(symbol->keyword Child))
                              ,(string->keyword (symbol->string Child)))
                            ,%xpr)
                           ,(if Parent
                              `((,Parent #:?) ,%xpr)
                              #f)))))
           ,@(map (lambda (key args)
                    (receive (fa va fchecks vcheck)
                      (dissect key args)
                      `((,key)
                        (,%lambda ,(append fa va)
                           (,%make-message
                             ;,(symbol->keyword Child)  ;;;;
                             ,(string->keyword (symbol->string Child))
                             ,key
                             ,@fchecks
                             ,@(if (null? va)
                                 va
                                 (list vcheck)))))))
                  keys xargs)
           (,%else
             ,(if Parent
                `(,Parent ,%key)
                `(,%error ',Child "wrong key" ,%key)))))
        ))
   (,%define-syntax ,Child-case
     (,%er-macro-transformer
       (,%lambda (f r c?)
         (,%let ((msg (cadr f)) (variants (cddr f)))
           `(,',%case-variant ,',Child
                           ,msg
                           ,@variants)))))
     ))))))

;;; (define-abstract-type Child Parent ..
;;;   (variant-key (a a? ...) ...)
;;;   | (variant-key (a a? ...) ... as as? ...)
;;;    ....
;;;   (with
;;;     ((key (x x? ...) ...)
;;;      | (key (x x? ...) ... xs xs? ...))
;;;      xpr ....)
;;;     ....)))
;;; ->
;;; (define Child
;;;   (let ((Child #f))
;;;     (let ((%Child #f))
;;;       (let ()
;;;         (define-algebraic-type Child Parent ..
;;;           (variant-key (a a? ...) ...)
;;;           | (variant-key (a a? ...) ... as as? ...)
;;;            ....)
;;;         (set! %Child Child))
;;;       (set! CChild %CChild))
;;;   (case-lambda
;;;     (() '((key (x x? ...) ...)
;;;           | (key (x x? ...) ... xs xs? ...))
;;;           xpr ....)
;;;          ....)))))
;;;     ((key)
;;;      (lambda (x ...) | (x ... . xs) xpr ....)
;;;      ....))))  ; type checks still missing
;;; ---------------------------------------------------------------
;;; defines a hidden algebraic type with keys variant-key ...,
;;; and exports a selector routine, Child, which, when called with the
;;; #:? keyword, returns the type predicate, when called with another
;;; keyword, returns the corresponding routine and when called without
;;; argument, returns information on the abstract type.
;;; Note that the exported objects in the with clause have access to the
;;; hidden algebraic type, which can be processed via Child-case
;;; Moreover, a destructure macro, Child-case, is generated, which specializes
;;; case-variant.
(define-syntax define-abstract-type
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((Child (cadr form))
            (Parent (if (symbol? (caddr form))
                      (caddr form)
                      #f))
            (rest (if (symbol? (caddr form))
                    (cdddr form)
                    (cddr form)))
            (%with (rename 'with))
            )
        (receive (variants routines)
          (let loop ((rest rest) (variants '()))
            (cond
              ((compare? (caar rest) %with)
               (values (reverse variants) (cdar rest)))
              ((null? rest)
               (error 'define-abstract-type "no with clause"))
              (else
                (loop (cdr rest) (cons (car rest) variants)))))
          (let ((keys (map car variants))
                (headers (map car routines))
                (bodies (map cdr routines))
                (Child-case (symbol-append Child '-case))
                (%Child (symbol-append '% Child))
                (%map (rename 'map))
                (%<<< (rename '<<<))
                (%let (rename 'let))
                (%set! (rename 'set!))
                (%case (rename 'case))
                (%name (rename 'name))
                (%else (rename 'else))
                (%error (rename 'error))
                (%begin (rename 'begin))
                (%lambda (rename 'lambda))
                (%define (rename 'define))
                (%list-of? (rename 'list-of?))
                (%case-lambda (rename 'case-lambda))
                (%case-variant (rename 'case-variant))
                (%define-syntax (rename 'define-syntax))
                (%er-macro-transformer (rename 'er-macro-transformer))
                (%define-algebraic-type (rename 'define-algebraic-type))
                )
            (let ((names (map car headers))
                  (xargs (map cdr headers))
                  (dissect
                    (lambda (key args)
                      (receive (fas vas)
                        ;(split-at-symbol args)
                        (let loop ((tail args) (head '()))
                          (cond
                            ((null? tail)
                             (values (reverse head) tail))
                            ((symbol? (car tail))
                             (values (reverse head) tail))
                            (else
                              (loop (cdr tail) (cons (car tail) head)))))
                        (values
                          (map car fas)
                          (if (null? vas) vas (car vas))
                          (map (lambda (f)
                                 `(,%<<< '(,Child ,key) ,@f))
                               fas)
                          (if (null? vas)
                            vas
                            `(,%<<< '(,Child ,key)
                              ,(car vas)
                              ,@(map (lambda (v)
                                       `(,%list-of? ,v))
                                     (cdr vas))))))))
              )
`(,%begin ;; order is important
   (,%define-syntax ,Child-case
     (,%er-macro-transformer
       (,%lambda (f r c?)
         (,%let ((msg (cadr f)) (variants (cddr f)))
           `(,',%case-variant ,',Child
                              ,msg
                              ,@variants)))))
   (,%define ,Child
     (,%let ((,Child #f))
       (,%let ((,%Child #f))
         (,%let ()
           ,(if Parent
              `(,%define-algebraic-type ,Child ,Parent ,@variants)
              `(,%define-algebraic-type ,Child ,@variants))
           (,%set! ,%Child ,Child))
         (,%set! ,Child ,%Child))
       (,%case-lambda
         (() (,Child))
         ((,%name)
          (,%case ,%name
             ((#:?) (,Child #:?))
             ,@(map (lambda (key args body)
                      (receive (fa va fchecks vcheck)
                        (dissect key args)
                        `((,key)
                          (,%lambda ,(append fa va)
                             (,%let ,(map (lambda (i c)
                                            `(,i ,c))
                                          fa fchecks)
                                (,%let ,(if (null? va)
                                          va
                                          `((,va ,vcheck)))
                                  ,@body))))))
                    names xargs bodies)
            (,%else
              ,(if Parent
                   `(,Parent ,%name)
                   `(,%error ',Child 
                      "invalid name"
                      ,%name))))))))
   ))))))))

;;; (messages sym ..)
;;; ------------------
;;; documentation procedure
(define messages
  (let ((alist '(
    (messages
      procedure:
      (messages sym ..)
      "documentation procedure")
    (case-variant
      macro:
      "(case-variant type msg"
      "  (variant-key (arg ...) xpr ....)"
      "  ..."
      "  (else xpr ....) ..)"
      "destructures msg of type depending on its variants"
      "by means of pattern-matching against (variant-key (arg ...))"
      "and executes the corresponding body xpr ....")
    (define-algebraic-type
      macro:
      "(define-algebraic-type Child Parent .."
      "   (variant-key (a a? ...) ...)"
      "   | (variant-key (a a? ...) ... as as? ...)"
      "   ....)"
      "defines a selector routine, Child, which, when called with the"
      "#:? keyword returns the type predicate, when called with another"
      "keyword, returns the corresponding message-constructor."
      "When Child is called with no argument, it returns information"
      "on the type."
      "Generates a specialisation, Child-case, of the"
      "case-variant macro as well")
    (define-abstract-type
      macro:
      "(define-abstract-type Child Parent .."
      "  (variant-key (a a? ...) ...)"
      "  | (variant-key (a a? ...) ... as as? ...)"
      "   ...."
      "  (with"
      "    ((key (x x? ...) ...)"
      "     | (key (x x? ...) ... xs xs? ...))"
      "     xpr ....)"
      "    ....))"
      "defines a hidden algebraic type with keys variant-key ...,"
      "and exports a selector routine, Child, which, when called with"
      "the #:? keyword, returns the type predicate, when called with"
      "another keyword, returns the corresponding routine and when"
      "called without argument, returns information on the abstract type."
      "Note that the exported objects in the with clause have access to"
      "the hidden algebraic type, which can be processed by"
      "case-variant.")
    (make-message
      procedure:
      (make-message type-key key . args)
      "type constructor")
    (message?
      procedure:
      (message? xpr)
      "type predicate")
    (message-type
      procedure:
      (message-type msg)
      "type accessor: returns type key")
    (message-key
      procedure:
      (message-key msg)
      "type accessor: returns instance key")
    (message-data
      procedure:
      (message-data msg)
      "type accessor: returns data vector")
    (message-of?
      procedure:
      (message-of? type-key)
      "returns a predicate which checks,"
      "if its argument is a message of type-key")
    )))
    (case-lambda
      (()
       (map car alist))
      ((sym)
       (let ((pair (assq sym alist)))
         (if pair
           (for-each print (cdr pair))
           (error "Not in list"
                  sym
                  (map car alist))))))))

  ) ; module messages