(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:}#)
  :export (

           macro-identifier
           macro-body
           macro-identifier-list
           macro-variadic?
           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

           make-environment in-environment?
           remove-identifier! add-identifier!
           get-identifier
           extend-environment
           disjoin-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 (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))
  (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)
  (hash-remove! (cpp-variables environment) key)
  environment)

(define (add-identifier! environment key value)
  (unless (string? key)
    (scm-error 'wrong-type-arg "add-identifier!"
               "Key must be a string, got: ~s"
               (list key) #f))
  (unless (macro? value)
    (scm-error 'wrong-type-arg "add-identifier!"
               "Value must be a macro, got: ~s"
               (list value) #f))
  (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 macro?))
  (let ((env (clone-environment environment)))
    (fold (lambda (m env) (add-identifier! env (macro-identifier m) m))
          env macros)))

(define (disjoin-macro environment name)
  (typecheck name string?)
  (let ((env (clone-environment environment)))
    (remove-identifier! env name)
    env))