#lang scheme/base

(require (for-syntax scheme/base
                     scheme/match
                     parser-tools/lex)
         (for-syntax "parser.ss")
         (for-syntax "quote.ss")
         (for-syntax "ast.ss")
         (for-syntax (prefix-in reader: "reader.ss")))
(require scheme/include
         "parser.ss"
         "ast.ss")

;; XXX: rename this module to parse.ss?

(provide parse declaration declaration-list include-c)

;; XXX: move these to a separate module?

(provide typedef struct union enum array pointer)

;; =============================================================================
;; COMPILE-TIME PARSING
;; =============================================================================

(define-for-syntax (string-literal-value stx)
  (let ([datum (syntax->datum stx)])
    (cond
      [(syntax-property stx 'scribble)
       => (lambda (p)
            (cond
              [(eq? p 'indentation) ""]
              [(and (pair? p) (eq? (car p) 'newline)) (cadr p)]
              [else datum]))]
      [else datum])))

(define-for-syntax (syntax-list x)
  (if (syntax? x) (syntax->list x) x))

(define-for-syntax (identifier-list? x)
  (andmap identifier? (syntax-list x)))

(define-for-syntax (string-list? x)
  (andmap (compose string? syntax->datum) (syntax-list x)))

(define-for-syntax (parse-scribble-strings name parser ts ss)
  (let* ([src (apply string-append (map string-literal-value ss))]
         [env (for/list ([type-id ts])
                (cons (syntax->datum type-id) 'type))]
         [src1 (car ss)]
         [offset (make-position (syntax-position src1)
                                (syntax-line src1)
                                (syntax-column src1))])
    (parameterize ([current-syntax-error-target name])
      (parser src env #:source (syntax-source src1) #:offset offset))))

(define-syntax (declaration stx)
  (syntax-case stx ()
    [(_ #:typedef (t ...) strings ...)
     (and (identifier-list? #'(t ...))
          (string-list? #'(strings ...)))
     (let ([ast (parse-scribble-strings 'declaration
                                        parse-decl
                                        (syntax->list #'(t ...))
                                        (syntax->list #'(strings ...)))])
       (syntax-quote-decl ast))]
    [(_ strings ...)
     (string-list? #'(strings ...))
     (syntax/loc stx
       #'(declaration #:typedef () strings ...))]))

(define-syntax (declaration-list stx)
  (syntax-case stx ()
    [(_ #:typedef (t ...) strings ...)
     (and (identifier-list? #'(t ...))
          (string-list? #'(strings ...)))
     (let ([ast (parse-scribble-strings 'declaration-list
                                        parse
                                        (syntax->list #'(t ...))
                                        (syntax->list #'(strings ...)))])
       (syntax-quote-map syntax-quote-decl ast))]
;     (let* ([src-stxes (syntax->list #'(strings ...))]
;            [src (apply string-append
;                        (map string-literal-value src-stxes))]
;            [env (for/list ([type-id (syntax->list #'(t ...))])
;                   (cons (syntax->datum type-id) 'type))])
;       (parameterize ([current-syntax-error-target 'declaration-list])
;         (let* ([src1 (car src-stxes)]
;                [offset (make-position (syntax-position src1)
;                                       (syntax-line src1)
;                                       (syntax-column src1))]
;                [ast (parse src env #:source (syntax-source stx) #:offset offset)])
;           (with-syntax ([ast (syntax-quote-map syntax-quote-decl ast)])
;             #'ast))))]
    [(_ strings ...)
     (string-list? #'(strings ...))
     (syntax/loc stx
       #'(declaration-list #:typedef () strings ...))]))

(define-syntax (include-c stx)
  (syntax-case stx ()
    [(_ path)
     (syntax/loc stx
       #'(include/reader path reader:read-syntax))]))

;; =============================================================================
;; PSEUDO-C MACROS
;; =============================================================================

(define-syntax (@type stx)
  (syntax-case stx ()
    [(@type id)
     (identifier? #'id)
     #'(make-type:ref 'id)]
    [(@type t)
     #'(let ([tmp t])
         (if (decl:type:tagged? tmp)
             (decl:type:tagged-type tmp)
             tmp))]))

(define-syntax (typedef stx)
  (syntax-case stx ()
    [(_ t name)
     #'(make-decl:type:def (@type t) '((name . #f)))]))

(define-syntax (struct stx)
  (syntax-case stx ()
    [(_ tag)
     (identifier? #'tag)
     #'(make-decl:type:tagged (make-type:struct 'tag #f))]
    [(_ tag (field ...))
     (identifier? #'tag)
     #'(make-decl:type:tagged (make-type:struct 'tag (list (struct-field field) ...)))]
    [(_ (field ...))
     #'(make-decl:type:tagged (make-type:struct #f (list (struct-field field) ...)))]))

(define-syntax (struct-field stx)
  (syntax-case stx ()
    [(_ [t name])
     #'`(name . ,(@type t))]
    [(_ name)
     #'`(name . #f)]))

(define-syntax (union stx)
  (syntax-case stx ()
    [(_ tag)
     (identifier? #'tag)
     #'(make-decl:type:tagged (make-type:union 'tag #f))]
    [(_ tag (variant ...))
     (identifier? #'tag)
     #'(make-decl:type:tagged (make-type:union 'tag (list (union-variant variant) ...)))]
    [(_ (variant ...))
     #'(make-decl:type:tagged (make-type:union #f (list (union-variant variant) ...)))]))

(define-syntax (union-variant stx)
  (syntax-case stx ()
    [(_ [t name])
     #'`(name . ,(@type t))]
    [(_ name)
     #'`(name . #f)]))

(define-syntax (enum stx)
  (syntax-case stx ()
    [(_ tag)
     (identifier? #'tag)
     #'(make-decl:type:tagged (make-type:enum 'tag #f))]
    [(_ tag (variant ...))
     (identifier? #'tag)
     #'(make-decl:type:tagged (make-type:enum 'tag (list (enum-variant variant) ...)))]
    [(_ (variant ...))
     #'(make-decl:type:tagged (make-type:enum #f (list (enum-variant variant) ...)))]))

(define-syntax (enum-variant stx)
  (syntax-case stx ()
    [(_ [name expr])
     #'`(name . ,(make-expr:lit 'int expr))]
    [(_ name)
     #'`(name . #f)]))

(define array (procedure-rename make-type:array 'array))
(define pointer (procedure-rename make-type:pointer 'pointer))