(define-module (c cpp-environment)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-88)
  :use-module (ice-9 hash-table)
  :use-module (hnh util object)
  :use-module (hnh util type)
  :use-module (hnh util lens)
  :use-module ((c cpp-environment function-like-macro) :prefix #{fun:}#)
  :use-module ((c cpp-environment object-like-macro)   :prefix #{obj:}#)
  :use-module ((c cpp-environment internal-macro)      :prefix #{int:}#)
  :use-module ((c unlex) :select (unlex))
  :export (

           macro-identifier
           macro-body
           macro-identifier-list
           macro-variadic?
           cpp-macro?
           ;; pprint-macro

           enter-active-if
           enter-inactive-if
           flip-flop-if
           leave-if
           in-comment-block?

           enter-file
           leave-file
           bump-line
           current-line
           current-file

           function-macro?
           object-macro?
           internal-macro?

           cpp-environment
           cpp-environment?
           cpp-if-status
           ;; cpp-variables
           cpp-file-stack

           make-environment in-environment?
           remove-identifier add-identifier
           get-identifier
           extend-environment
           disjoin-macro

           pprint-environment
           pprint-macro
           ))

(define (macro-identifier x)
  (define identifier
   (cond ((obj:object-like-macro? x)   obj:identifier)
         ((fun:function-like-macro? x) fun:identifier)
         ((int:internal-macro? x)      int:identifier)
         (else (scm-error 'wrong-type-arg "macro-identifier"
                          "Not a macro: ~s"
                          (list x) #f))))
  (identifier x))


(define (macro-body-proc macro)
  (cond ((obj:object-like-macro? macro)   obj:body)
        ((fun:function-like-macro? macro) fun:body)
        ((int:internal-macro? macro)      int:body)
        (else (scm-error 'wrong-type-arg "macro-body"
                         "Not a macro: ~s"
                         (list macro) #f))))

(define macro-body
  (case-lambda ((macro)       ((macro-body-proc macro) macro))
               ((macro value) ((macro-body-proc macro) macro value))))

(define macro-identifier-list fun:identifier-list)
(define macro-variadic? fun:variadic?)

(define function-macro? fun:function-like-macro?)
(define object-macro?   obj:object-like-macro?)
(define internal-macro? int:internal-macro?)

(define (cpp-macro? x)
  (or (obj:object-like-macro? x)
      (fun:function-like-macro? x)
      (int:internal-macro? x)))




(define-type (cpp-environment)
  (cpp-if-status type: (list-of (memv '(outside active-if inactive-if)))
                 default: '(outside))
  ;; not exported since type signatures don't hold inside the hash table
  ;; TODO replace hash table with something that doesn't require copying the
  ;; entire structure every time
  (cpp-variables type: hash-table? default: (make-hash-table))
  (cpp-file-stack type: (and (not null?)
                             (list-of (pair-of string? exact-integer?)))
                  default: '(("*outside*" . 1))))




(define (enter-active-if environment)
  (modify environment cpp-if-status xcons 'active-if))

(define (enter-inactive-if environment)
  (modify environment cpp-if-status xcons 'inactive-if))

;; for #else
(define (flip-flop-if environment)
  ((if (in-comment-block? environment)
       enter-active-if
       enter-inactive-if)
   (leave-if environment)))

(define (leave-if environment)
  (modify environment cpp-if-status cdr))

(define (in-comment-block? environment)
  (eq? 'inactive-if (get environment cpp-if-status car*)))



(define (enter-file environment filename)
  (modify environment cpp-file-stack xcons (cons filename 1)))

(define (leave-file environment)
  (modify environment cpp-file-stack cdr))

(define current-line (compose-lenses cpp-file-stack car* cdr*))

(define current-file (compose-lenses cpp-file-stack car* car*))

(define* (bump-line environment optional: (count 1))
  (modify environment current-line + count))




(define (make-environment) (cpp-environment))

(define (clone-hash-table ht)
  (alist->hash-table (hash-map->list cons ht)))

(define (clone-environment environment)
  (modify environment cpp-variables clone-hash-table))

(define (in-environment? environment key)
  (hash-get-handle (cpp-variables environment) key))

(define (remove-identifier environment key)
  (typecheck key string?)

  (let ((environment (clone-environment environment)))
    (hash-remove! (cpp-variables environment) key)
    environment))

(define (add-identifier environment key value)
  (typecheck key string?)
  (typecheck value cpp-macro?)

  (let ((environment (clone-environment environment)))
    (hash-set! (cpp-variables environment) key value)
    environment))

(define (get-identifier environment key)
  (hash-ref (cpp-variables environment) key))


(define (extend-environment environment macros)
  (typecheck macros (list-of cpp-macro?))
  (fold (lambda (m env) (add-identifier env (macro-identifier m) m))
        environment macros))

(define (disjoin-macro environment name)
  (typecheck name string?)
  (remove-identifier environment name))




(define* (pprint-environment environment optional: (port (current-error-port)))
  (display "== Environment ==\n")
  (hash-for-each (lambda (key macro)
                   (pprint-macro macro port)
                   (newline port))
                 (cpp-variables environment)))

(define* (pprint-macro x optional: (p (current-output-port)))
  (cond ((internal-macro? x)
         (format p "/* ~a INTERNAL MACRO */"
                 (macro-identifier x)))
        ((object-macro? x)
         (format p "#define ~a ~a"
                 (macro-identifier x)
                 (unlex (macro-body x))))
        ((function-macro? x)
         (format p "#define ~a(~a) ~a"
                 (macro-identifier x)
                 (string-join (append (macro-identifier-list x)
                                      (if (macro-variadic? x)
                                          '("...") '()))
                              "," 'infix)
                 (unlex (macro-body x))))))