SRFI-99

;; -*- mode: Scheme; -*-
((category data)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "SRFI-99 record types")
 (doc-from-wiki)
 (needs)
 (test-depends test)
 (files "srfi-99.scm"))

;; -*- mode: Scheme; -*-
(repo fossil "https://chust.org/repos/chicken-{egg-name}")

(uri targz "https://chust.org/repos/chicken-{egg-name}/tarball/{egg-name}.tar.gz?uuid=v{egg-release}")
(release "1.4.4")
(release "1.4.3")
(release "1.4.2")
(release "1.4.1")
(release "1.4.0")
(release "1.3.0")
(release "1.2.0")
(release "1.1.1")
(release "1.1.0")
(release "1.0.0")

;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(require-library
 srfi-1 srfi-69
 data-structures lolevel)

(module srfi-99-primitives
  (%make-rtd %get-rtd rtd? record?
   %rtd-name %rtd-uid %rtd-child-uids %rtd-fields %rtd-parent %rtd-properties
   %rtd-child-uid?
   %rtd-count-fields %rtd-count-all-fields
   %rtd-field-ref %rtd-field-find)
  (import
   scheme chicken





   srfi-69)

(define-values (%make-rtd %get-rtd)
  (letrec ((%link!
	    (lambda (rtd)
	      (do ((rtd rtd (%rtd-parent rtd)) (uid (%rtd-uid rtd))) ((not rtd))
		(cond

)

(module srfi-99-records-procedural
  (make-rtd rtd?
   rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
  (import
   scheme chicken

   srfi-1 srfi-69 srfi-99-primitives data-structures)

(define (make-rtd name fields . args)
  (let-values (((fields)
		(list->vector
		 (map
		  (lambda (field)
		    (cond

(module srfi-99-records-inspection
  (record? record-rtd
   rtd-name rtd-uid rtd-sealed? rtd-opaque? rtd-parent
   rtd-field-names rtd-all-field-names rtd-field-mutable?
   make-rtp rtd-properties rtd-all-properties)
  (import
   scheme chicken
   srfi-1 srfi-69 srfi-99-primitives srfi-99-records-procedural data-structures)

(define (record-rtd v)
  (and (record? v)
       (%get-rtd (##sys#slot v 0))))

(define (rtd-name rtd)
  (##sys#check-structure rtd 'rtd 'rtd-name)

   define-record-predicate
   %define-record-predicate/default
   define-record-field
   %define-record-field/mutable-default %define-record-field/immutable-default
   define-record-property
   define-record-printer)
  (import
   scheme (except chicken define-record-type define-record-printer)
   srfi-99-records-procedural)

(define-syntax %define-record-constructor/default
  (ir-macro-transformer
   (lambda (stx inject id=)
     (let* ((rtd (cadr stx))
	    (name (symbol-append 'make- (strip-syntax rtd))))

     (##sys#register-record-printer (rtd-uid rtd) expr))))

)

(module srfi-99-records
  ()
  (import
   scheme chicken)
  (reexport
   srfi-99-records-procedural srfi-99-records-inspection
   srfi-99-records-syntactic)

)

(module srfi-99-variants
  (define-variant-type
   define-variant-constructor
   variant-case)
  (import


   scheme (except chicken define-record-type)

   srfi-99-records lolevel)

(define-syntax define-variant-type
  (syntax-rules ()
    ((define-variant-type (rtd option ...) predicate
       (variant field ...)
       ...)
     (begin

	(error "no matching variant"))))))

)

(module srfi-99
  ()
  (import
   scheme chicken)
  (reexport
   srfi-99-records srfi-99-variants)

)

;; -*- mode: Scheme; -*-
(compile -s -O2 -d1 "srfi-99.scm"
	 -j srfi-99
	 -j srfi-99-primitives
	 -j srfi-99-records
	 -j srfi-99-records-procedural
	 -j srfi-99-records-inspection
	 -j srfi-99-records-syntactic
	 -j srfi-99-variants)

(cond-expand
 (enable-static
  (compile -c -O2 -d1 "srfi-99.scm"
	   -unit srfi-99))
 (else
  ))

(compile -s -O2 -d0 "srfi-99.import.scm")
(compile -s -O2 -d0 "srfi-99-primitives.import.scm")
(compile -s -O2 -d0 "srfi-99-records.import.scm")
(compile -s -O2 -d0 "srfi-99-records-procedural.import.scm")
(compile -s -O2 -d0 "srfi-99-records-inspection.import.scm")
(compile -s -O2 -d0 "srfi-99-records-syntactic.import.scm")
(compile -s -O2 -d0 "srfi-99-variants.import.scm")

(install-extension
 'srfi-99
 `("srfi-99.so"
   ,@(cond-expand
      (enable-static
       '("srfi-99.o"))
      (else
       '()))
   "srfi-99.import.so"
   "srfi-99-primitives.import.so"
   "srfi-99-records.import.so"
   "srfi-99-records-procedural.import.so"
   "srfi-99-records-inspection.import.so"
   "srfi-99-records-syntactic.import.so"
   "srfi-99-variants.import.so")
 `((version "1.4.4")
   ,@(cond-expand
      (enable-static
       '((static "srfi-99.o")))
      (else
       '()))))

;; -*- mode: Scheme; -*-
;;
;; This file is part of SRFI-99 for CHICKEN
;; Copyright (c) 2011 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(require-extension
 srfi-99 test)

(test-group "procedural layer"

  (test-group "RTD creation"
    (test-assert "null record" (rtd? (make-rtd 'foo '#())))
    (test-error "bad name" (make-rtd 42 '#()))
    (test-error "bad fields" (make-rtd 'foo '#((murks quark))))
    (test-error "bad parent" (make-rtd 'foo '#() 'murks)))

  (test-group "RTD properties"
    (test "type name" 'foo (rtd-name (make-rtd 'foo '#())))
    (test "type UID" 'bar (rtd-uid (make-rtd 'foo '#() #f #:uid 'bar)))
    (test "unsealed type" #f (rtd-sealed? (make-rtd 'foo '#() #f)))
    (test "sealed type" #t (rtd-sealed? (make-rtd 'foo '#() #f #:sealed #t)))
    (test "transparent type" #f (rtd-opaque? (make-rtd 'foo '#() #f)))
    (test "opaque type" #t (rtd-opaque? (make-rtd 'foo '#() #f #:opaque #t)))
    (test "implicit immutable field" #f (rtd-field-mutable? (make-rtd 'foo '#(x)) 'x))
    (test "explicit immutable field" #f (rtd-field-mutable? (make-rtd 'foo '#((immutable x))) 'x))
    (test "implicit mutable field" #t (rtd-field-mutable? (make-rtd 'foo '#((x))) 'x))
    (test "explicit mutable field" #t (rtd-field-mutable? (make-rtd 'foo '#((mutable x))) 'x)))

  (test-group "RTD instances"
    (let ((t (make-rtd 'foo '#(x (y)))))
      (define make-t (rtd-constructor t))
      (define t? (rtd-predicate t))
      (define t-x (rtd-accessor t 'x))
      (define t-y (rtd-accessor t 'y))
      (test "instance detection" #t (t? (make-t 1 2)))
      (test "non-instance detection" #f (t? 'foo))
      (test "field access" 42 (t-x (make-t 42 23)))
      (test "field mutation" 23 (let ((r (make-t 42 0))) (set! (t-y r) 23) (t-y r)))
      (test-error "disallowed field mutation" (set! (t-x (make-t 42 23)) 0))))

  (test-group "RTD inheritance"
    (let* ((t0 (make-rtd 'foo '#(x y)))
	   (t1 (make-rtd 'bar '#(z) t0 #:sealed #t)))
      (define make-t1 (rtd-constructor t1 '#()))
      (define t0? (rtd-predicate t0))
      (define t1? (rtd-predicate t1))
      (test "direct field enumeration" '#(z) (rtd-field-names t1))
      (test "full field enumeration" '#(x y z) (rtd-all-field-names t1))
      (test "direct instance detection" #t (t1? (make-t1)))
      (test "indirect instance detection" #t (t0? (make-t1)))
      (test-error "disallowed derivation" (make-rtd 'baz '#() t1))))
  
  (test-group "properties"
    (let* ((p0 (make-rtp 42))
	   (p1 (make-rtp))
	   (t0 (make-rtd 'foo '#(x) #:property p0 23))
	   (t1 (make-rtd 'bar '#(y) t0 #:property p1 'y)))
      (define make-t0 (rtd-constructor t0 '#(x)))
      (define make-t1 (rtd-constructor t1 '#(y)))
      (test "direct type property access" 23 (p0 #f t0))
      (test "derived type property access" 23 (p0 #f t1))
      (test "direct instance property access" 23 (p0 (make-t0 1)))
      (test "derived instance property access" 23 (p0 (make-t1 1)))
      (test-error "illegal field property access" (p1 #f t1))
      (test "field property access" 2 (p1 (make-t1 2)))))

)

(test-group "syntactic layer" (let ()

  (define-record-type foo
    #t #t
    x (y))
  
  (test-assert "RTD" (rtd? foo))
  (test-assert "constructor" (procedure? make-foo))
  (test-assert "predicate" (procedure? foo?))
  (test-assert "immutable accessor" (procedure? foo-x))
  (test-assert "mutable accessor" (procedure? foo-y))
  (test-assert "mutable mutator" (procedure? foo-y-set!))
  (test-assert "mutable accessor setter" (procedure? (setter foo-y)))

))

(test-group "variants" (let ()

  (define-variant-type foo
    #t
    (foobar x)
    (foobaz x y))
  
  (test-assert "RTD" (rtd? foo))
  (test-assert "predicate" (procedure? foo?))
  (test-assert "variant constructors" (every procedure? (list foobar foobaz)))
  (test-assert "variant RTDs" (every rtd? (map procedure-data (list foobar foobaz))))
  (test "variant extraction" 2 (variant-case foo (foobaz 1 2)
				 ((foobar x) x)
				 ((foobaz y) y)))
  (test "else clause" 42 (variant-case foo (foobaz 1 2)
			   ((foobar x) x)
			   (else 42)))
  (test-error "match error" (variant-case foo (foobaz 1 2)
			      ((foobar x) x)))

))
	 
(test-exit)