(define-module (c preprocessor2)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-71)
  :use-module (srfi srfi-88)
  :use-module (ice-9 match)
  :use-module (c cpp-environment)
  :use-module (c eval2)
  :use-module ((c cpp-environment function-like-macro)
               :select (function-like-macro variadic? identifier-list))
  :use-module ((c cpp-environment object-like-macro) :select (object-like-macro))
  :use-module ((c cpp-environment internal-macro) :select (internal-macro))
  :use-module ((hnh util) :select (-> intersperse aif swap))
  :use-module ((hnh util lens) :select (set modify))
  :use-module (hnh util path)
  :use-module (hnh util type)
  :use-module ((c lex2) :select (lex #|lexeme|# lexeme? lexeme-body lexeme-type lexeme-noexpand))
  :use-module ((c trigraph) :select (replace-trigraphs))
  :use-module ((c line-fold) :select (fold-lines))
  :use-module (c unlex)
  :use-module (c cpp-types)
  :use-module (c cpp-util)
  :export ())

(define-syntax-rule (alist-of variable key-type value-type)
  (build-validator-body variable (list-of (pair-of key-type value-type))))

(define parameter-map? (of-type? (alist-of string? (list-of lexeme?))))


;; Expand ## tokens
;; TODO
;; Tokens is the body of the macro
(define (expand## macro tokens)
  (typecheck macro macro?)
  (typecheck tokens (list-of lexeme?))
  tokens)

;; parameters is a lexeme list, as returned by parse-parameter-list
(define (build-parameter-map macro parameters)
  (typecheck macro macro?)
  (typecheck parameters (list-of (list-of lexeme?)))
  (if (macro-variadic? macro)
      (let ((head rest (split-at parameters (length (macro-identifier-list macro)))))
        (cons (cons "__VA_ARGS__" (concatenate (intersperse
                                                (lex ",")
                                                rest)))
              (map cons (macro-identifier-list macro) head)))
      (map cons
           (macro-identifier-list macro)
           parameters)))


;; TODO Deprecate?
(define (parameter-map->macro-list param-map)
  (typecheck param-map parameter-map?)
  (map (lambda (pair)
         (let ((identifier (car pair))
               (body (cdr pair)))
           (object-like-macro
            identifier: identifier
            body: body)))
       param-map))


(define (expand# macro parameter-map)
  (typecheck macro macro?)
  (typecheck parameter-map parameter-map?)
  (let loop ((tokens (macro-body macro)))
    (cond ((null? tokens) '())
          ((equal? '(punctuator "#")
                   (lexeme-body (car tokens)))
           (let ((trimmed (drop-whitespace (cdr tokens))))
             (let ((x (identifier-token? (car trimmed)))
                   (rest (cdr trimmed)))
               (unless (member x (macro-identifier-list macro))
                 (scm-error 'macro-expand-error "expand#"
                            "'#' is not followed by a macro parameter: ~s"
                            (list x) #f))
               (cons (stringify-tokens (assoc-ref parameter-map x))
                     (loop rest)))))
          (else (cons (car tokens) (loop (cdr tokens)))))))

;; expand function like macro
;; parameter is a list of lexeme-lists, each "top level" element matching one
;; argument to the macro
(define (apply-macro environment macro parameters)
  (typecheck environment cpp-environment?)
  ;; Each element should be the lexeme list for that argument
  (typecheck parameters (list-of (list-of lexeme?)))
  (typecheck macro macro?)
  (when (or (and (variadic? macro)
                 (> (length (macro-identifier-list macro))
                    (length parameters)))
            (and (not (variadic? macro))
                 (not (= (length (macro-identifier-list macro))
                         (length parameters)))))
    (scm-error 'cpp-arity-error "apply-macro"
               ;; TODO better error message for variadic macros
               "Wrong number of arguments to macro ~s, expected ~s, got ~s"
               (list (macro-identifier macro)
                     (length (macro-identifier-list macro))
                     (length parameters))
               (list macro)))
  (let ()
    (define parameter-map (build-parameter-map macro parameters))
    (define stringify-resolved (expand# macro parameter-map))
    ;; TODO resolve ##
    (define resulting-body stringify-resolved #; (expand## macro stringify-resolved))

    (define (bound-identifier? id)
      (and (string? id)
           (or (and (variadic? macro) (string=? id "__VA_ARGS__"))
               (member id (macro-identifier-list macro)))))

    (let loop ((tokens resulting-body))
      (cond ((null? tokens) '())
            ;; TODO the parameters should be macro-expanded before being inserted
            ((identifier-token? (car tokens))
             bound-identifier?
             => (lambda (id) (append (assoc-ref parameter-map id)
                                (loop (cdr tokens)))))
            (else (cons (car tokens) (loop (cdr tokens))))))))



;; Expand object-like macro

;; #define VALUE 10
;; #define str(x) #x
;; #define OTHER str(VALUE)
;; OTHER
;; ⇒ "VALUE"

;; remaining-tokens should be the token stream just after the name of the macro
(define (expand-macro environment macro noexpand-list remaining-tokens)
  (typecheck environment cpp-environment?)
  (typecheck macro macro?)
  (typecheck remaining-tokens (list-of lexeme?))
  (typecheck noexpand-list (list-of string?))

  (let ((name (macro-identifier macro)))
    (cond ((object-macro? macro)
           (values environment (append (fold (swap mark-noexpand)
                                             (macro-body macro)
                                             (cons name noexpand-list))
                                       remaining-tokens)))

          ((function-macro? macro)
           (let ((containing remaining newlines (parse-parameter-list remaining-tokens)))
             (values (bump-line environment newlines)
                     (append (fold (swap mark-noexpand)
                                   (apply-macro environment macro containing)
                                   (cons name noexpand-list))
                             remaining))))

          ((internal-macro? macro)
           (let ((containing remaining newlines (parse-parameter-list remaining-tokens)))
             (values (bump-line environment newlines)
                     (append (fold (swap mark-noexpand)
                                   ((macro-body macro) environment containing)
                                   (cons name noexpand-list))
                             remaining))))

          (else
           (scm-error 'wrong-type-arg "expand-macro"
                      "Macro isn't a macro: ~s"
                      (list macro) #f)))))

;; Takes a list of preprocessing tokens, and returns two values
;; if the last token was '...'
;; and a list of strings of all token names
;; Note that this is ONLY #define f(x) forms
;; not usage forms
(define (parse-identifier-list tokens)
  (typecheck tokens (list-of lexeme?))
  (let loop ((tokens (remove whitespace-token? tokens)) (done '()))
    (cond ((null? tokens) (values #f (reverse done)))
          ((identifier-token? (car tokens))
           => (lambda (id) (loop (cdr tokens) (cons id done))))
          ((equal? '(punctuator "...") (lexeme-body (car tokens)))
           (unless (null? (cdr tokens))
             (scm-error 'cpp-error "parse-identifier-list"
                        "'...' only allowed as last argument in identifier list. Rest: ~s"
                        (list (cdr tokens)) #f))
           (values #t (reverse done)))
          ((equal? '(punctuator ",") (lexeme-body (car tokens)))
           (loop (cdr tokens) done))
          (else (scm-error 'cpp-error "parse-identifier-list"
                           "Unexpected preprocessing-token in identifier list: ~s"
                           (list (car tokens)) #f)))))




;; returns three values:
;; - a list of tokens where each is a parameter to the function like macro
;; - the remaining tokenstream
;; - how many newlines were encountered
;; The standard might call these "replacement lists"
(define (parse-parameter-list tokens*)
  (typecheck tokens* (list-of lexeme?))
  (let %loop ((depth 0) (newlines 0) (current '())
              (parameters '()) (tokens tokens*) (%first-iteration? #t))
    (define* (loop tokens key:
                   (depth depth) (newlines newlines)
                   (current current) (parameters parameters))
      (%loop depth newlines current parameters tokens #f))
    (let ((current* (if (zero? depth)
                        current
                        (cons (car tokens) current))))
      (cond ((null? tokens)
             (scm-error 'misc-error "parse-parameter-list"
                        "Ran out of tokens while parsing: ~s"
                        (list tokens*) #f))
            ((newline-token? (car tokens))
             (loop (cdr tokens) newlines: (1+ newlines) current: current*))
            ((whitespace-token? (car tokens))
             (loop (cdr tokens) current: current*))

            ((equal? '(punctuator "(") (lexeme-body (car tokens)))
             (loop (cdr tokens) depth: (1+ depth) current: current*))
            ((equal? '(punctuator ")") (lexeme-body (car tokens)))
             (if (= 1 depth)
                 ;; return value
                 (values
                  (if (null? parameters)
                      (cond ((null? current) '())
                            ((every whitespace-token? current) '())
                            (else (reverse
                                   (cons (cleanup-whitespace (reverse current))
                                         parameters))))
                      (reverse
                       (cond ((null? current) parameters)
                             ((every whitespace-token? current) parameters)
                             (else (cons (cleanup-whitespace (reverse current))
                                         parameters)))))

                  (cdr tokens)
                  newlines)
                 (loop (cdr tokens)
                       depth: (1- depth)
                       current: current*)))
            ((equal? '(punctuator ",") (lexeme-body (car tokens)))
             (if (= 1 depth)
                 (loop (cdr tokens)
                       current: '()
                       parameters:
                       (cons (cond ((null? current) '())
                                   ((every whitespace-token? current) '())
                                   (else (cleanup-whitespace (reverse current))))
                             parameters))
                 (loop (cdr tokens) current: current*)))
            (else
             (loop (cdr tokens) current: current*))))))


;; Add __FILE__ and __LINE__ object macros to the environment
(define (join-file-line environment)
  (define file (current-file environment))
  (define line (current-line environment))
  (extend-environment
   environment
   ;; 6.10.8
   (list
    (object-like-macro
     identifier: "__FILE__"
     body: (lex (format #f "~s" file)))
    (object-like-macro
     identifier: "__LINE__"
     body: (lex (number->string line))))))

(define (c-search-path) (make-parameter (list "." "/usr/include")))

;; #include <stdio.h>
(define (resolve-h-file string)
  (typecheck string string?)
  (cond ((path-absolute? string) string)
        (else
         (let ((filename
                (find file-exists?
                      (map (lambda (path-prefix)
                             (path-append path-prefix string))
                           (c-search-path)))))
           (if filename filename
               (scm-error 'cpp-error "resolve-h-file"
                          "Can't resolve file: ~s"
                          (list string) #f))))))

;; #include "myheader.h"
(define (resolve-q-file string)
  (typecheck string string?)
  ;; This should always be a fallback (6.10.2, p. 3)
  (cond (else (resolve-h-file string))))

(define defined-macro
  (internal-macro
   identifier: "defined"
   body: (lambda (environment arguments)
           (typecheck arguments (and (list-of (list-of lexeme?))
                                     (not null?)))
           (aif (identifier-token? (car (list-ref arguments 0)))
                (let ((in-env (boolean->c-boolean (in-environment? environment it))))
                  (lex (number->string in-env)))
                (scm-error 'cpp-error "defined"
                           "Invalid parameter list to `defined': ~s"
                           (list tokens) #f)))))

;; environment, tokens → environment
(define (handle-pragma environment tokens)
  (match tokens
    (`((preprocessing-token (identifier "STDC")) (whitespace ,_) ...
       (preprocessing-token (identifier ,identifier)) (whitespace ,_) ...
       (preprocessing-token (identifier ,on-off-switch)) (whitespace ,_) ...)
     ;; TODO actually do something with the pragmas (probably just store them in the environment)
     (format (current-error-port)
             "#Pragma STDC ~a ~a" identifier on-off-switch)
     environment)
    (_ (format (current-error-port)
               "Non-standard #Pragma: ~s~%" tokens)
       environment)))


;; TODO
;; (define _Pragma-macro
;;   (internal-macro
;;    identifier: "_Pragma"
;;    body: (lambda (environment tokens)
;;            )))

;; TODO
(define (resolve-constant-expression tokens)
  (typecheck tokens (list-of lexeme?))
  'TODO
  )

(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 (variadic? x)
                                          '("...") '()))
                              "," 'infix)
                 (unlex (macro-body x))))))

(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 (mark-noexpand1 token name)
  (modify token lexeme-noexpand xcons name))

(define (mark-noexpand tokens name)
  ;; (typecheck tokens (list-of lexeme?))
  ;; (typecheck name string?)
  (map (lambda (token) (mark-noexpand1 token name)) tokens))

(define (marked-noexpand? token)
  (cond ((identifier-token? token)
         => (lambda (id) (member id (lexeme-noexpand token))))
        (else #f)))

;; Expands a token-stream which contains no pre-processing directives (#if:s, ...)
(define (resolve-token-stream environment tokens)
  (typecheck environment cpp-environment?)
  (typecheck tokens (list-of lexeme?))
  ;; (pprint-environment environment)
  ;; (format (current-error-port) "~a~%~%" (unlex tokens))
  (let loop ((environment environment) (tokens tokens))
    (cond ((null? tokens) '())
          ((car tokens)
           (lambda (x) (and (identifier-token? x)
                       (not (marked-noexpand? x))))
           => (lambda (token)
                (call-with-values
                    (lambda () (maybe-extend-identifier environment
                                                   (identifier-token? token)
                                                   (lexeme-noexpand token)
                                                   (cdr tokens)))
                  loop)))
          (else (cons (car tokens)
                      (loop environment (cdr tokens)))))))

;; returns a new environment
;; handle body of #if
;; environment, (list token) → environment
(define (resolve-for-if environment tokens)
  (typecheck environment cpp-environment?)
  (typecheck tokens (list-of lexeme?))

  (-> (extend-environment environment defined-macro)
      (resolve-token-stream tokens)
      resolve-constant-expression
      c-boolean->boolean
      (if (enter-active-if environment)
          (enter-inactive-if environment))))

;; environment, string, (list token) → environment, (list token)
(define (maybe-extend-identifier environment identifier noexpand-list remaining-tokens)
  (typecheck environment cpp-environment?)
  (typecheck identifier string?)
  (typecheck remaining-tokens (list-of lexeme?))
  (typecheck noexpand-list (list-of string?))
  (cond ((get-identifier environment identifier)
         => (lambda (value) (expand-macro (join-file-line environment)
                                     value
                                     noexpand-list
                                     remaining-tokens)))
        (else ; It wasn't an identifier, leave it as is
         (values environment
                 (append (mark-noexpand (lex identifier)
                                        identifier)
                         remaining-tokens)))))

(define (resolve-and-include-header environment tokens)
  (typecheck environment cpp-environment?)
  (typecheck tokens (list-of lexeme?))

  ;; TODO rewrite without match
  (let loop ((%first-time #t) (tokens tokens))
    (match (drop-whitespace tokens)
      ((`(header-name (h-string ,str)) rest ...)
       (cond ((remove whitespace-token? rest)
              (negate null?)
              => (lambda (tokens)
                   (scm-error 'cpp-error "resolve-and-include-header"
                              "Unexpected tokens after #include <>: ~s"
                              (list tokens) #f))))
       (handle-preprocessing-tokens
        environment
        (-> str resolve-h-file read-file tokenize)))

      ((`(header-name (q-string ,str)) rest ...)
       (cond ((remove whitespace-token? rest)
              (negate null?)
              => (lambda (tokens)
                   (scm-error 'cpp-error "resolve-and-include-header"
                              "Unexpected tokens after #include <>: ~s"
                              (list tokens)
                              #f))))
       (handle-preprocessing-tokens
        environment
        (-> str resolve-q-file read-file tokenize)))

      (tokens
       (unless %first-time
         (scm-error 'cpp-error "resolve-and-include-header"
                    "Failed parsing tokens: ~s"
                    (list tokens) #f))
       (loop #f (resolve-token-stream environment tokens))))))

;; environment, tokens → environment
(define (handle-line-directive environment tokens*)
  (typecheck environment cpp-environment?)
  (typecheck tokens* (list-of lexeme?))

  ;; TODO rewrite without match
  (let loop ((%first-time #t) (tokens tokens*))
    (match tokens
      (`((preprocessing-token (pp-number ,line)) (whitespace ,_) ... rest ...)
       (match rest
         (`((preprocessing-token (string-literal ,file)) (whitespace ,_) ...)
          (-> environment
              (set current-line line)
              (set current-file file)))
         (`((whitespace ,_) ...)
          (set environment current-line line))
         (_ (unless %first-time
              (scm-error 'cpp-error "handle-line-directive"
                         "Invalid line directive: ~s"
                         (list tokens*) #f))
            (loop #f (resolve-token-stream environment tokens)))))
      (_ (unless %first-time
           (scm-error 'cpp-error "handle-line-directive"
                      "Invalid line directive: ~s"
                      (list tokens*) #f))
         (loop #f (resolve-token-stream environment tokens))))))

;; environment, tokens → environment
(define (resolve-define environment tokens)
  (typecheck environment cpp-environment?)
  (typecheck tokens (list-of lexeme?))

  (let ((identifier (identifier-token? (car tokens)))
        (tail (cdr tokens)))
    (-> environment
        bump-line
        (add-identifier!
         identifier
         (cond ((and (not (null? tail))
                     (equal? '(punctuator "(") (lexeme-body (car tail))))
                ;; function like macro
                (let ((identifier-list
                       replacement-list
                       (break (lambda (token) (equal? '(punctuator ")") (lexeme-body token) ))
                              (cdr tail))))
                  (let ((variadic? identifiers (parse-identifier-list identifier-list)))
                    (function-like-macro
                     identifier: identifier
                     variadic?: variadic?
                     identifier-list: identifiers
                     ;; NOTE 6.10.3 states that there needs to be at least on whitespace here
                     ;; cdr drops the end parenthesis of the definition
                     ;; surrounding whitespace is not part of the replacement list (6.10.3 p.7)
                     body: (drop-whitespace-both (cdr replacement-list))))))
               (else (object-like-macro
                      identifier: identifier
                      body: (drop-whitespace-both tail))))))))




;; environment, tokens -> environment, tokens
(define (handle-preprocessing-tokens environment tokens)
  (let loop ((environment environment) (tokens tokens))
    (define (err fmt . args)
      (scm-error 'cpp-error "handle-preprocessing-tokens"
                 (string-append "~a:~a " fmt)
                 (cons* (current-file environment)
                        (current-line environment)
                        args)
                 #f))

    ;; TODO all of this needs to be surounded with a conditional for
    ;; environmentns if status. However, ensure that each directive
    ;; starts at start of line

    (match tokens
      ('() '())
      ((`(whitespace "\n") `(whitespace ,_) '... '(preprocessing-token (puntuator "#")) rest ...)
       ;; Line tokens are those in this line,
       ;; while remaining tokens are the newline, follewed by the rest of the files tokens
       (let ((line-tokens remaining-tokens (tokens-until-eol rest)))
         ;; Actual tokens just removes all whitespace between "#" and "define"
         (let ((actual-tokens (drop-whitespace line-tokens)))
           (if (null? actual-tokens)
               (loop (bump-line environment) remaining-tokens)
               (match (car actual-tokens)
                 (`(preprocessing-token (identifier "if"))
                  (let ((environment (resolve-for-if environment actual-tokens)))
                    (loop environment remaining-tokens)))

                 (`(preprocessing-token (identifier "ifdef"))
                  (match actual-tokens
                    ((`(preprocessing-token (identifier ,id)) _ ...)
                     (loop
                      ((if (in-environment? environment id)
                           enter-active-if enter-inactive-if)
                       environment)
                      remaining-tokens))
                    (_ (err "Non identifier in ifdef: ~s" actual-tokens))))

                 (`(preprocessing-token (identifier "ifndef"))
                  (match actual-tokens
                    ((`(preprocessing-token (identifier ,id)) _ ...)
                     (loop
                      ((if (in-environment? environment id)
                           enter-inactive-if enter-active-if)
                       environment)
                      remaining-tokens))
                    (_ (err "Non identifier in ifndef: ~s" actual-tokens))))

                 ('(preprocessing-token (identifier "else"))
                  ;; TODO
                  'TODO
                  )

                 ('(preprocessing-token (identifier "elif"))
                  (-> environment leave-if
                      (resolve-for-if actual-tokens)
                      (loop remaining-tokens)))

                 ('(preprocessing-token (identifier "endif"))
                  (loop (leave-if environment) remaining-tokens))

                 ('(preprocessing-token (identifier "include"))
                  (call-with-values
                      (lambda () (resolve-and-include-header environment (cdr actual-tokens)))
                    (lambda (environment tokens)
                     (loop environment (append tokens remaining-tokens)))))

                 ('(preprocessing-token (identifier "define"))
                  (let ((env (resolve-define environment (cdr actual-tokens))))
                    (loop env remaining-tokens))
                  )

                 ('(preprocessing-token (identifier "undef"))
                  (loop (match actual-tokens
                          (`((preprocessing-token (identifier ,id)))
                           (-> environment bump-line (remove-identifier! id))))
                        remaining-tokens))

                 ('(preprocessing-token (identifier "line"))
                  (loop (handle-line-directive environment actual-tokens)
                        remaining-tokens))

                 ('(preprocessing-token (identifier "error"))
                  ;; NOTE this is an "expected" error
                  (throw 'cpp-error actual-tokens))

                 ('(preprocessing-token (identifier "pragma"))
                  (loop (handle-pragma environment actual-tokens)
                        remaining-tokens)))))))

      ((`(preprocessing-token (identifier ,id)) rest ...)
       (maybe-extend-identifier environment id rest loop))

      (('(whitespace "\n") rest ...)
       (cons '(whitespace "\n") (loop (bump-line environment) rest)))

      ((token rest ...) (cons token (loop environment rest))))))



(define (read-file path)
  (call-with-input-file path (@ (ice-9 rdelim) read-string)))

(define (comment->whitespace token)
  (if (comment-token? token)
      (car (lex " "))
      token))

(define (comments->whitespace tokens)
  (map comment->whitespace tokens))

;;; 5.1.11.2 Translation phases

(define (tokenize string)
  (-> string
;;; 1. trigraph replacement
      replace-trigraphs
;;; 2. Line folding
      fold-lines
;;; 3. Decomposition into preprocenning tokens, whitespaces, and comments
      lex
;;; 4. Execution of preprocessing directives, all preprocessing directives are then deleted
      comments->whitespace
      ;; squeeze-whitespace-blocks
      ))