;;;; type-checks-structured.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(declare (bound-to-procedure ##sys#structure?))

(module type-checks-structured

(;export
  check-procedure check-closure
  check-input-port
  check-output-port
  check-list
  check-alist
  check-plist
  check-pair
  check-blob
  check-vector
  check-structure
  check-record
  check-record-type
  check-string
  ;
  define-check-structure)

(import scheme)
(import (chicken base))     ; for `include'
(import (chicken type))
(import (chicken syntax))
(import (only (chicken blob) blob?))
(import type-errors-structured type-checks-basic)

;(import-for-syntax (only (chicken base) symbol-append))

(: check-structure (* 'a * #!optional * -> 'a))
(: check-record (* 'a * #!optional * -> 'a))
(: check-record-type (* 'a * #!optional * -> 'a))
(: check-string (* * #!optional * -> string))
(: check-procedure (* * #!optional * -> procedure))
(: check-closure (* * #!optional * -> procedure))
(: check-input-port (* * #!optional * -> input-port))
(: check-output-port (* * #!optional * -> output-port))
(: check-list (* * #!optional * -> list))
(: check-plist (* 'a #!optional * -> 'a))
(: check-alist (* 'a #!optional * -> 'a))
(: check-pair (* * #!optional * -> pair))
(: check-blob (* * #!optional * -> blob))
(: check-vector (* * #!optional * -> vector))

(cond-expand

  (unsafe

    (define alist? (lambda _ #t))
    (define plist? (lambda _ #t))

    (define (check-structure loc obj . _) obj)
    (define (check-record loc obj . _) obj)
    (define (check-record-type loc obj . _) obj) )

  (else

    ;;These are weak predicates. Only check for structure.

    (define-inline (list-every p? obj)
      (or (null? obj)
          (and (pair? obj)
               (let every ((ls obj))
                 (or (null? ls)
                     (and (p? (car ls))
                          (every (cdr ls) ) ) ) ) ) ) )

    (define (alist? obj)
      ;since anything can be a key no stronger check possible
      (list-every pair? obj) )

    (define (plist? obj)
      ;since anything can be a key no stronger check possible
      (and (list? obj) (even? (length obj))) )

    ;;

    ;NOTE the module must export the tag as a binding, not all do! (allows generated tags)

    (define (check-structure loc obj tag . args)
      (unless (##sys#structure? obj tag)
        (error-structure loc obj tag (optional args)))
      obj )

    (define (check-record loc obj tag . args)
      (unless (##sys#structure? obj tag)
        (error-record loc obj tag (optional args)))
      obj )

    (define (check-record-type loc obj tag . args)
      (unless (##sys#structure? obj tag)
        (error-record-type loc obj tag (optional args)))
      obj ) ) )

;;

(define-check-type string)
(define-check-type procedure)
(define check-closure check-procedure)
(define-check-type input-port)
(define-check-type output-port)
(define-check-type list)
(define-check-type plist)
(define-check-type alist)
(define-check-type pair)
(define-check-type blob)
(define-check-type vector)

  ;NOTE the module really should export the tag as a binding, not all do!
  ;(allows named generated tags) but this allows a non-symbol tag value w/
  ;a symbol name

(define-syntax define-check-structure
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (let ((_define (rnm 'define))
            (_apply (rnm 'apply))
            (_loc (rnm 'loc))
            (_obj (rnm 'obj))
            (_args (rnm 'args))
            (_check-structure (rnm 'check-structure)))
       ;FIXME strip-syntax tag ?
       (let* ((tagnam (cadr frm))
              (tag (if (null? (cddr frm)) tagnam (caddr frm)))
              (nam (symbol-append 'check- (strip-syntax tagnam))) )
         ;FIXME apply for known, single, optional arg - #!optional needs rnm?
         `(,_define (,nam ,_loc ,_obj . ,_args)
            (,_apply ,_check-structure ,_loc ,_obj ,tag ,_args)) ) ) ) ) )

) ;module type-checks-structured