bind-type   macro

;; bind-type expects: (symbol type [docstring])
(define-macro (bind-type . args)
  ;; (println 'bind-type args)
  (if (null? args)
      (impc:compiler:print-compiler-error "Bind type missing arguments! (symbol type [docstring])"))
  (let* ((symbol (car args))
         (type_1 (cadr args))
         (type (string->symbol
                (string-append "<"
                 (string-join
                  (map (lambda (x)
                         (if (impc:ti:typealias-exists? x)
                             (impc:ir:pretty-print-type (impc:ti:get-typealias-type x))
                             x))
                       (impc:ir:get-pretty-tuple-arg-strings (symbol->string type_1)))
                  ",")
                 ">")))
         (docstring (if (string? (car (reverse args))) (car (reverse args)) ""))
         (extras (cl:remove #f (map (lambda (x) (if (pair? x) x #f)) args)))
         (printer? (if (assoc-strcmp 'printer? extras)
                       (cdr (assoc-strcmp 'printer? extras))
                       #t))
         (copy? (if (assoc-strcmp 'copy? extras)
                       (cdr (assoc-strcmp 'copy? extras))
                       #t))
         (constructor? (if (assoc-strcmp 'constructor? extras)
                           (cdr (assoc-strcmp 'constructor? extras))
                           #t)))
    (if (not (char=? (string-ref (symbol->string type_1) (- (string-length (symbol->string type_1)) 1)) #\>))
        (impc:compiler:print-bad-type-error type_1 "is a malformed tuple type"))
    (if (impc:ti:bang-type? type) ;; send generic named types to aot
        (impc:aot:insert-generic-type `(bind-type ,@args)))
    (if (<> (impc:ir:get-ptr-depth type) 0)
        (impc:compiler:print-bad-type-error type "cannot be a pointer"))
    (if (not (char=? (string-ref (symbol->string type) 0) #\<))
        (impc:compiler:print-bad-type-error type "must be a tuple type"))
    `(begin
       (set! *impc:ir:get-type-callback-off* #t)
       (let* ((ags (impc:ir:get-pretty-tuple-arg-strings ,(symbol->string type)))
              ;; expand all non-explict generic types
              ;; i.e. expand list* into list:<!a,list*>*
              (expand-polys (map (lambda (k)
                                   (if (and (impc:ti:get-generictype-candidate-types (impc:ir:get-base-type k))
                                            (not (equal? (impc:ir:get-base-type k) ,(symbol->string symbol)))) ;; for recursive case!
                                       (impc:ir:pointer++
                                        (string-append (impc:ir:get-base-type k) ":"
                                                       (symbol->string (impc:ti:get-generictype-candidate-types (impc:ir:get-base-type k))))
                                        (impc:ir:get-ptr-depth k))
                                       k))
                                 ags))
              (newtype (string-append "<" (string-join expand-polys ",") ">")))
         ;; (println 'authors_type: ,(symbol->string type))
         ;; (println 'transformed_type: newtype)
         ;; and on with the show!
         (if (impc:ti:bang-type? newtype) ;; then must be poly type
             (begin
               (impc:ti:register-new-generictype ',symbol (string->symbol newtype))
               (impc:compiler:print-binding-details-to-log "GenrType:" ',symbol ',type))
             (let ((typelist (cons *impc:ir:tuple* (impc:ir:get-type-from-pretty-tuple ,(symbol->string type)
                                                                                       ,(symbol->string symbol)))))
               (if (llvm:compile-ir (string-append "%" ,(symbol->string symbol) " = type "
                                                   (impc:ir:get-type-str typelist)))
                   (begin (impc:ti:register-new-namedtype ,(symbol->string symbol) typelist ,docstring)
                          (impc:compiler:print-binding-details-to-log "DataType:" ',symbol ',type))
                   (impc:compiler:print-compiler-error "could not compile IR for type" ',type)))))
       ;; the next line is to help specialize any element types that may not already be specialized!
       (map (lambda (a) (impc:ir:get-type-from-pretty-str a (symbol->string ',(car args)))) (impc:ir:get-pretty-tuple-arg-strings ,(symbol->string type)))
       (set! *impc:ir:get-type-callback-off* #f)
       ;; (sys:wait (now))
       ;; now compile data constructor
       (impc:ti:compile-type-dataconstructors
        ',symbol
        (if (impc:ti:get-generictype-candidate-types ',symbol)
            (symbol->string (impc:ti:get-generictype-candidate-types ',symbol))
            (impc:ir:pretty-print-type (impc:ti:get-namedtype-type ,(symbol->string symbol))))
        (if (impc:ti:get-generictype-candidate-types ',symbol) #t #f)
        ,printer?
        ,copy?
        ,constructor?))))