(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 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?

           enter-active-if
           enter-inactive-if
           leave-if

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

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

           cpp-environment
           cpp-if-status cpp-variables

           make-environment in-environment?
           remove-identifier! add-identifier!
           get-identifier
           extend-environment

           ))

(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 macro)
  (define body-proc
    (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))))
  (body-proc macro))

(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 ((negate 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))

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



(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 (in-envirnoment? 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 (clone-hash-table ht)
  (alist->hash-table (hash-map->list cons ht)))

(define (extend-environment environment macros)
  (let ((env (modify environment cpp-variables clone-hash-table)))
    (fold (lambda (m env) (add-identifier! env (macro-identifier m) m))
          env macros)))