#lang racket
(provide type-> type-or check-type current-stack fold/type)
;;--------------------------------
(require racket/match)
(require (planet wcy/anaphora))
(require "mpost-utils.rkt")
(define ((type-> . in-types) . in-targets)
  (let lp ((types  in-types)
           (targets in-targets))
    (cond
     ((and (null? targets) (null? types)) #t)
     ((and (null? targets) (not (null? types))) types)
     ((and (not (null? targets)) (null? types))
      (error "more arguments are provided." in-types in-targets))
     ((and (not (null? targets)) (not (null? types)))
      (if (eq? (car types) (car targets)) 
          (lp (cdr types) (cdr targets)) 
          #f))
     (else (error 'never-goes-here)))))
(define ((type-or . type-defs) . objs)
  (for/or ((f (in-list type-defs)))
          (apply f objs)))
(define current-stack (make-parameter '()))
(define ((check-type . type-defs) . objs)
  (aif (aand (apply (apply type-or type-defs) objs)
             (return-type it)) 
       it
       (error (string-append
               "type error:\n"
               (pretty-format (current-stack)) "\n"
               "given types:" (pretty-format objs) "\n")) ))
(define (return-type type)
  (match type
    ((list v) v)
    (else #f)))
(define ((fold/type f2) x1 x2 . xs)
  (if (null? xs)
      (f2 x1 x2)
      (aif (return-type (f2 x1 x2))
           (apply (fold/type f2) it xs)
           #f)))