;;;; petty-types.lisp

(in-package #:petty-types)

(defun type-specifier-p (thing)
  "Returns T if THING is a valid TYPE-SPECIFIER, otherwise returns NIL."
  (ignore-errors
   (typep nil thing)
   t))

(deftype type-specifier ()
  '(satisfies type-specifier-p))

(defun sequence-of-predicate-for (cont type &optional len)
  "Returns the name of a predicate that checks whether its argument is a
   sequence of type CONT whose values are all of type TYPE."
  (check-type type type-specifier "A TYPE-SPECIFIER")
  (check-type cont type-specifier "A TYPE-SPECIFIER")
  (assert (subtypep cont 'sequence) (cont) "~s is not a subtype of SEQUENCE." cont)
  (check-type cont symbol "A SYMBOL")
  (assert (or (eq len '*) (typep len 'fixnum)) (len) "LEN must be '* or a fixnum")
  (let ((name
          (let ((*package* #.(find-package :petty-types)))
            (apply #'a:symbolicate cont :-of- (write-to-string len) :- (a:flatten type))))
        (len
          (when (typep len 'fixnum)
            len)))
    (prog1 name
      (unless (fboundp name)
        (setf (symbol-function name)
              (let ((is-type (lambda (xs) (typep xs type))))
                (lambda (xs)
                  (and (typep xs cont)
                       (or (not len) (= len (length xs)))
                       (every is-type xs)))))))))

(defun ordered-sequence-of (types)
  "Returns the name of a predicate that checks whether its argument is a
list of exactly (LENGTH TYPES) members such that the type of the NTH
member is the NTH member of TYPES."
  (assert (every #'type-specifier-p types) (types)
          "At least one member of ~s is not a type specifier"
          types)
  (let ((name
          (let ((*package* #.(find-package :petty-types)))
           (apply #'a:symbolicate :tuple-
                  (mapcar #'write-to-string (a:flatten types))))))
    (prog1 name
      (unless (fboundp name)
        (setf (symbol-function name)
              (lambda (xs)
                (and (listp xs)
                     (loop :for (x . xs2) :on xs
                           :for (ty . types2) :on types
                           :always (typep x ty)
                           :finally (return (and (endp xs2) (endp types2)))))))))))

(deftype list-of (type &optional len)
  "Type specifier for lists all of the same TYPE."
  `(and list (satisfies ,(sequence-of-predicate-for 'list type len))))

(deftype vector-of (type &optional len)
  "Type specifier for vectors all of the same TYPE."
  `(and vector (satisfies ,(sequence-of-predicate-for 'vector type len))))

(deftype tuple (&rest types)
  "Type specifier for a list of specific types"
  `(and list (satisfies ,(ordered-sequence-of types))))

(deftype optional (type)
  "Type specifier for an optional type."
  `(or null ,type))