;;;; type-checks-basic.scm  -*- Scheme -*-
;;;; Kon Lovett, Jun '18

(module type-checks-basic

(;export
  ;
  define-check-type
  define-check+error-type
  ;
  check-defined-value
  check-bound-value
  check-minimum-argument-count check-argument-count)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken syntax))
(import type-errors-basic)

(: check-defined-value (* 'a #!optional * -> 'a))
(: check-bound-value (* 'a #!optional * -> 'a))

(: check-minimum-argument-count (* fixnum fixnum -> fixnum))
(: check-argument-count (* fixnum fixnum -> fixnum))

;;

#| ;UNUSED
(define-syntax unbound-value
  (syntax-rules ()
    ((unbound-value)
      (##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )

(define-syntax unbound-value?
  (syntax-rules ()
    ((unbound-value? ?val)
      (eq? (unbound-value) ?val) ) ) )

(define-syntax unbound?
  (syntax-rules ()
    ((unbound? ?sym)
      (unbound-value? (##sys#slot ?sym 0)) ) ) )
|#

;;

(cond-expand
  (unsafe
    (define-syntax define-check-type
      (er-macro-transformer
        (lambda (frm rnm cmp)
          (let ((_define (rnm 'define)))
            (let* ((*typ (strip-syntax (cadr frm)))
                   (chknam (symbol-append 'check- *typ)) )
              `(,_define (,chknam loc obj . _) obj) ) ) ) ) )

    (define defined-value? (lambda _ #t))
    (define bound-value? (lambda _ #t))

    (define (check-minimum-argument-count loc obj . _) obj)
    (define (check-argument-count loc obj . _) obj) )
  (else
    (define-syntax define-check-type
      (er-macro-transformer
        (lambda (frm rnm cmp)
          (let ((_define (rnm 'define))
                (_unless (rnm 'unless))
                (_the (rnm 'the))
                (_import (rnm 'import))
                (_chicken (rnm 'chicken))
                (_type (rnm 'type))
                (_loc (rnm 'loc))
                (_obj (rnm 'obj))
                (_args (rnm 'args))
                (_optional (rnm 'optional)) )
            (let* ((*typ (strip-syntax (cadr frm)))
                   (pred (if (null? (cddr frm)) (symbol-append *typ '?)
                             (caddr frm)))
                   (chknam (symbol-append 'check- *typ))
                   (errnam (symbol-append 'error- *typ)) )
              #; ;NOTE requires a defined type so ?
              `(,begin
                (,_define ,chknam)
                (,_let ()
                  (: (* ,*typ #!optional * -> ,*typ))
                  (,_set! ,chknam (,_lambda (,_loc ,_obj . ,_args)
                    (,_unless (,pred (,_the * ,_obj))
                      (,errnam ,_loc ,_obj (,_optional ,_args)) )
                    ,_obj ) ) ) )
              ;caller must add type annotation
              ;(: (* ,*typ #!optional * -> ,*typ)) ;cannot be pure - must be called!
              `(,_define (,chknam ,_loc ,_obj . ,_args)
                 (,_import (,_chicken ,_type))
                 ;must override compiler ideas about the actual value type
                 ;passed, otherwise it assumes all good, sometimes, not
                 ;always.
                 (,_unless (,pred (,_the * ,_obj))
                   (,errnam ,_loc ,_obj (,_optional ,_args)))
                 ,_obj ) ) ) ) ) )

    ;; Is the object non-void?

    (define (defined-value? obj) (not (eq? (void) obj)))

    ;; Is the object bound to value?

    ;is obj the value from the de-ref of an unbound variable.
    ;could only occur in a rather unsafe calling environnment.

    (define (bound-value? obj) (not (##core#inline "C_unboundvaluep" obj)))

    ;;

    (define (check-minimum-argument-count loc argc minargc)
      (unless (<= minargc argc) (error-minimum-argument-count loc argc minargc))
      argc )

    (define (check-argument-count loc argc maxargc)
      (unless (<= argc maxargc) (error-argument-count loc argc maxargc))
      argc ) ) )

;;

(define-check-type defined-value)
(define-check-type bound-value)

;;

;<type-symbol> [<type-predicate> [<message-string>]]

(define-syntax define-check+error-type
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (let ((_begin (rnm 'begin))
            (_define-check-type (rnm 'define-check-type))
            (_define-error-type (rnm 'define-error-type)) )
        (let* ((typ (cadr frm))
               (pred (and (not (null? (cddr frm))) (caddr frm)))
               (mesg (and pred (not (null? (cdddr frm))) (cadddr frm))) )
          `(,_begin
             (,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
             (,_define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) ) )

) ;module type-checks-basic