;;; Sex fmt-c output writer

(import
  scheme
  (scheme base)                         ; make-parameter
  (chicken base)
  (chicken string)
  (chicken syntax)
  brev-separate                         ; fn, flatten
  fmt
  sex-fmt-c
  matchable
  (chicken irregex)                     ; unkebabify
  srfi-1                                ; lists
  srfi-13                               ; strings
  utils)

;;; egg `tree' not ported to CHICKEN 6 yet
(define (tree-map f tree)
  (cond ((null? tree) (list))
        ((pair? tree) (cons (tree-map f (car tree))
                            (tree-map f (cdr tree))))
        (else (f tree))))

;;; How much #line information to emit:
;;;
;;;   statement -- before every statement.
;;;   toplevel  -- one directive per toplevel form.
;;;   none      -- none at all, for reading -C output by eye.
(define sex-line-directives (make-parameter 'statement))

(define (anchor-statements?)
  (eq? (sex-line-directives) 'statement))

(define (line-directive src)
  ;; `%line' is fmt-c's #line directive. cpp-line concatenates its
  ;; second argument verbatim, so the file name arrives already quoted.
  `(%line ,(cdr src) ,(fmt #f #\" (car src) #\")))

(define (walk-body stmts)
  "Walk a statement list, re-anchoring each statement that has a known
source location. Only statement positions may be walked this way: a
#line inside an expression is a C syntax error."
  (if (anchor-statements?)
      (append-map (lambda (s)
                    (let ((src (form-source s)))
                      (if src
                          (list (line-directive src) (walk-expr s))
                          (list (walk-expr s)))))
                  (pack-comments stmts))
      (map walk-expr (pack-comments stmts))))

(define (walk-stmt s)
  "A statement in a slot that holds exactly one form -- an `if' arm.
Splicing is not possible there, since c-if reads anything past the arm
as an `else if' chain, so the anchor and the statement are wrapped in
`%begin': a statement sequence that emits no braces of its own (the
surrounding c-block supplies them)."
  (let ((src (and (pair? s) (anchor-statements?) (form-source s))))
    (if src
        `(%begin ,(line-directive src) ,(walk-expr s))
        (walk-expr s))))

;;; A `;' comment reads as a form, so one written inside a construct
;;; with positional slots lands in a slot and shifts everything after
;;; it. So take the positional slots by skipping comments, and hand
;;; the comments back to be emitted just before the statement
(define (take-slots forms n)
  "Three values: the comment forms skipped over, the next N non-comment
forms, and what remains."
  (let loop ((fs forms) (n n) (comments (list)) (slots (list)))
    (cond ((or (= n 0) (null? fs))
           (values (reverse comments) (reverse slots) fs))
          ((comment-form? (car fs))
           (loop (cdr fs) n (cons (car fs) comments) slots))
          (else
           (loop (cdr fs) (- n 1) comments (cons (car fs) slots))))))

;;; `%begin' is a statement sequence that emits no braces of its own, so
;;; the comments simply precede the statement.
(define (with-comments comments form)
  (if (null? comments)
      form
      `(%begin ,@(map walk-expr comments) ,form)))

(define (walk-if-clauses clauses)
  "(test stmt test stmt ... [else-stmt]) -- tests stay expressions."
  (let loop ((cs clauses) (acc (list)))
    (cond ((null? cs) (reverse acc))
          ((null? (cdr cs))                    ; trailing else statement
           (reverse (cons (walk-stmt (car cs)) acc)))
          (else (loop (cddr cs)
                      (cons (walk-stmt (cadr cs))
                            (cons (walk-expr (car cs)) acc)))))))

(define (unkebabify sym)
  (case sym
    ((-) sym)
    ((--) sym)
    ((->) sym)
    ((-=) sym)
    (else
     (string->symbol
      (irregex-replace/all "-(?!>)" (symbol->string sym) "_")))))

(define (atom-to-fmt-c atom)
  (case atom
    ((fn) '%fun)
    ((prototype) '%prototype)
    ((do) '%block-begin)
    ((define) '%define)
    ((pointer) '%pointer)
    ((array) '%array)
    ((attribute) '%attribute)
    ((¤) 'vector-ref)
    ((include) '%include)
    ;; a `|' inside a symbol has to be escaped to be written in
    ;; a Scheme source, so we just rename it in fmt-c compatible
    ;; way
    ((|\||) 'bit-or)
    ((|\|\||) '%or)
    ((|\|=|) 'bit-or=)
    ;; uh things we do for c89 compatibility
    ((bool) 'int)
    ((true) 1)
    ((false) 0)
    (else
     (if (symbol? atom)
         (unkebabify atom)
         atom))))

(define (maybe-unwrap-type type)
  (if (and (list? type)
           (= 1 (length type)))
      (car type)
      type))

;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
(define (strip-comment-marker text)
  (string-trim-both (string-trim text #\;)))

(define (walk-comment texts)
  (list '%comment
        (string-append " "
                       (string-intersperse (map strip-comment-marker texts)
                                           "\n ")
                       " ")))

;;; Merge multiple lines of /* */ into single block
(define (pack-comments forms)
  (let loop ((fs forms) (acc (list)))
    (cond
     ((null? fs) (reverse acc))
     ((comment-form? (car fs))
      (let ((first (car fs)))
        (let gather ((rest (cdr fs)) (texts (cdr first)) (line (form-line first)))
          (if (and (pair? rest)
                   (comment-form? (car rest))
                   line
                   (equal? (form-file first) (form-file (car rest)))
                   (eqv? (form-line (car rest)) (+ line 1)))
              (gather (cdr rest)
                      (append texts (cdr (car rest)))
                      (form-line (car rest)))
              (loop rest
                    (cons (if (eq? texts (cdr first))
                              first          ; a run of one, left alone
                              (copy-form-source! first (cons 'comment texts)))
                          acc))))))
     (else (loop (cdr fs) (cons (car fs) acc))))))

(define (walk-generic-toplevel form)
  (cond ((atom? form) (atom-to-fmt-c form))
        ((list? form) (map walk-generic-toplevel form))
        (else (sex-error form "malformed form" form))))

(define (walk-expr form)
  (match form
    ((? vector?)
     (list->vector
      (walk-expr (vector->list form))))
    ((? atom?)
     (atom-to-fmt-c form))
    ;; (comment "text") -> /* text */. `%comment' is the fmt-c directive.
    (('comment . text) (walk-comment text))
    ;; (dot-access obj field ...) -> obj.field... member access. `%.'
    ;; is the fmt-c directive for the `.' operator (see sex-fmt-c).
    (('dot-access . rest) (cons '%. (map walk-expr rest)))
    (('var . _) (walk-var form))
    ;; An expression has no room for a statement, so a comment in a
    ;; cast is dropped rather than relocated.
    (('cast . rest)
     (let-values (((comments slots _) (take-slots rest 2)))
       (list '%cast (walk-type (cadr slots)) (walk-expr (car slots)))))
    (('enum . _) (walk-enum form))
    (('c-or . rest) (apply c-or (map walk-expr rest)))
    (('c-bit-or . rest) (apply c-bit-or (map walk-expr rest)))
    (('c-bit-or= . rest) (apply c-bit-or= (map walk-expr rest)))

    ;; Statement positions. These are the only places a #line may go,
    ;; and each is spliced or wrapped according to what the
    ;; corresponding fmt-c procedure accepts.
    (('do . stmts) (cons '%block-begin (walk-body stmts)))
    (('if . clauses)
     (with-comments (filter comment-form? clauses)
       (cons 'if (walk-if-clauses (remove comment-form? clauses)))))
    (('while . rest)
     (let-values (((comments slots body) (take-slots rest 1)))
       (with-comments comments
         (cons* 'while (walk-expr (car slots)) (walk-body body)))))
    (('for . rest)
     (let-values (((comments slots body) (take-slots rest 3)))
       (with-comments comments
         (cons* 'for (walk-expr (car slots)) (walk-expr (cadr slots))
                (walk-expr (caddr slots))
                (walk-body body)))))
    ;; No anchor *between* switch clauses: c-switch requires every clause
    ;; to be a case/default form and errors on anything else. The clause
    ;; bodies are anchored from inside, which is what a debugger steps
    ;; onto -- a `case' label is not a statement.
    ;; A comment between clauses has to go too: c-switch requires every
    ;; clause to be a case/default form and errors on anything else.
    (('switch . rest)
     (let-values (((comments slots clauses) (take-slots rest 1)))
       (with-comments (append comments (filter comment-form? clauses))
         (cons* 'switch (walk-expr (car slots))
                (map walk-expr (remove comment-form? clauses))))))
    (('case . rest)
     (let-values (((comments slots body) (take-slots rest 1)))
       (with-comments comments
         (cons* 'case (walk-expr (car slots)) (walk-body body)))))
    (('case/fallthrough . rest)
     (let-values (((comments slots body) (take-slots rest 1)))
       (with-comments comments
         (cons* 'case/fallthrough (walk-expr (car slots)) (walk-body body)))))
    (('default . body) (cons 'default (walk-body body)))

    ;; Drop comments so they will not generate additional comma
    (else (map walk-expr (remove comment-form? form)))))

(define (walk-var form)
  ;; (var a int) -> (%var int a)
  ;; (var a (const int) 32) -> (%var (const int) a 32)
  ;; (var b [const char 512]) -> (%var (%array (const char) 512) b)
  ;; note: [...] is actually (¤ ...) after reading
  ;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c)
  ;; Likewise a declaration: drop any comment rather than shift the
  ;; name and type apart.
  (let ((form (cons (car form) (remove comment-form? (cdr form)))))
    `(%var
      ,(walk-type (third form))
      ,(atom-to-fmt-c (second form))
      .
      ,(if (null? (drop form 3))
           (list)
           (walk-expr (drop form 3)))))) ; optional init expression

(define (walk-type form)
  ;; int -> int
  ;; (const int) -> const int
  ;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512)
  ;; [float 8] -> (%array float 8)
  ;; (* const char) -> (const char *)
  ;; (const * const * const char) -> (const char * const * const)
  ;; (fn ((int) (float)) void) -> (%fun void ((int) (float)))
  (match form
    (('¤ . array-type)
     (if (integer? (last array-type))
         ;; sized array
         (let* ((type-list (drop-right array-type 1))
                (type (maybe-unwrap-type type-list))
                (size (last array-type)))
           `(%array ,(walk-type type)
                    ,size))
         ;; sugar for pointer... Do we really need it? Guess why not,
         ;; it's a strong semantic cue
         `(%array ,(walk-type (maybe-unwrap-type array-type)))))
    (('fn arglist ret-type)
     `(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
    (('fn . _)
     (sex-error form "malformed function type" form))

    ;; Special case: nested structs/unions
    ((or ('struct . _)
         ('union . _)) (walk-struct form))

    (('enum . _) (walk-enum form))
    (else
     (type-convert-to-c form))))

(define (has-pointer-star? form)
  (and (pair? form)
       (or (memq '* form)
           (any has-pointer-star? (filter pair? form)))))

;;; A `*' inside a sublist. Pointer chains are written flat -- (* * T),
;;; never (* (* T))
;;; Sublists that merely group, like (* (const struct suc)), contain
;;; no `*' and are fine.
(define (nested-pointer? type)
  (and (pair? type)
       (any has-pointer-star? (filter pair? type))))

(define (type-convert-to-c type)
  ;; Our pointers to C pointers
  ;; int -> int
  ;; * const char -> const char *
  ;; const * const char -> const char * const
  (when (nested-pointer? type)
    (sex-error type "pointer chains are written flat, as (* * T), not nested" type))
  (if (atom? type) (atom-to-fmt-c type)
      (flatten
       (tree-map atom-to-fmt-c
                 (flatten
                  (list-join (reverse (list-split type '*))
                             '(*)))))))

(define (walk-fn-def form)
  (match form
    (('fn name args ret-type . maybe-body)
     `(%fun
       ,(walk-type ret-type)
       ,(atom-to-fmt-c name)
       ,(walk-arglist args)
       .
       ,(walk-body maybe-body)))))

;;; TODO: isn't there a better way?
(define (is-probably-type form)
  (case (car form)
    ((¤ * const volatile struct union) #t)
    (else #f)))

(define (walk-arglist form)
  ;; E.g.:
  ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
  ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
  (map (fn
        (match x
          (('¤ . _) (walk-type x))

          ;; yeah shitty, but I don't know yet how to determine if the
          ;; first entry is part of the type and not an argument name
          ;; :(
          ((? is-probably-type) (walk-type x))

          ;; 1 element args are always type
          ((_) (walk-type x))

          ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
                                (list (walk-type var))))))
       (remove comment-form? form)))

(define (walk-function form)
  ;; (fn ret-type name arglist body) -> normal function
  ;; (fn ret-type name arglist) -> prototype
  (if (>= (length form) 5)
      (walk-fn-def form)
      (cons '%prototype (cdr (walk-fn-def form)))))

(define (process-struct-fields fields)
  (map (fn
        (let ((type (walk-type (last x))))
          (cons type (map atom-to-fmt-c (drop-right x 1)))))
       (remove comment-form? fields)))

(define (walk-struct form)
  (match form
    ((type (fields ...) . attrs)        ; anonymous struct
     `(,type ,(process-struct-fields fields)
             . ,(tree-map atom-to-fmt-c attrs)))
    ((type name)                        ; simple 'struct whatever', like in variable def
     `(,type ,(atom-to-fmt-c name)))
    ((type name (fields ...) . attrs)
     `(,type ,(atom-to-fmt-c name)
             ,(process-struct-fields fields)
             . ,(tree-map atom-to-fmt-c attrs)))
    (else (sex-error form "malformed aggregate definition" form))))

(define (walk-enum form)
  (match form
    ;; Naming one without defining it: `(var m (enum mood))', the same
    ;; shape walk-struct accepts for `(struct foo)'. Guarded, and
    ;; before the anonymous case, since `(enum (red green))' is also a
    ;; two-element form
    (('enum (? symbol? name))
     `(enum ,(atom-to-fmt-c name)))
    (('enum (values ...))
     `(enum ,(map atom-to-fmt-c values)))
    (('enum name (values ...))
     `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))
    (else (sex-error form "malformed enum" form))))

(define (walk-extern form)
  (match form
    (('fn . _)
     ;; extern function?.. What
     (list 'extern (walk-function form)))
    (('var . _)
     (list 'extern (walk-var form)))
    (else (sex-error form "extern must be followed by fn or var" form))))

(define (walk-public form)
  (match form
    (('fn . _)
     (walk-function form))
    (('var . _)
     (walk-var form))
    ((or ('define . _)
         ('defmacro . _)

         ('import . _)
         ('include . _)

         ('struct . _)
         ('union . _)
         ('enum . _)

         ('typedef . _))
     ;; ignore here, used in generating public interface
     (process-toplevel-form form))
    (else
     (sex-error form "pub must be followed by a definition" form))))

(define (process-toplevel-form form)
  (match form
    (('comment . text) (walk-comment text))
    (('fn . _) (list 'static (walk-function form)))
    (('var . _) (list 'static (walk-var form)))
    (('extern . rest) (walk-extern rest))
    ;; The cdr of a form has no location of its own, so hand it the
    ;; `pub' form's -- otherwise a complaint about what follows `pub'
    ;; cannot say where it was written
    (('pub . rest) (walk-public (copy-form-source! form rest)))
    ((or ('struct . _)
         ('union . _)) (walk-struct form))
    (('enum . _) (walk-enum form))
    (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
    (else (walk-expr form))))

(define (emit-c sex-forms)
  (for-each (lambda (form)
              ;; Forms the reader did not produce -- the prelude, and
              ;; anything a macro built that we could not attribute --
              ;; have no location and get no directive.
              (let ((src (and (not (eq? (sex-line-directives) 'none))
                              (form-source form))))
                (when src
                  (fmt #t (c-expr (line-directive src)))))
              (fmt #t (c-expr (process-toplevel-form form)) nl))
            (pack-comments sex-forms)))