#lang scheme/base

(require scheme/match
         "ast.ss")
(require (for-syntax scheme/base))
(require (for-template scheme/base
                       "ast.ss"))
(provide (except-out (all-defined-out) define-quoter))

(define-syntax (define-quoter stx)
  (syntax-case stx ()
    [(_ (f arg) @ qs [(type (src fields ...)) t] ...)
     (with-syntax ([body (syntax/loc stx
                           (match arg
                             [(struct type (src fields ...))
                              (let ([q-src (src->syntax src #f original?)])
                                (with-syntax ([@ (syntax-quote-src src)])
                                  (let-syntax ([qs (syntax-rules ()
                                                     [(_ expr)
                                                      (quasisyntax/loc q-src expr)])])
                                    t)))]
                             ...))])
       (syntax/loc stx
         (define (f arg [original? #t]) body)))]))

#;(define-syntax-rule (define-quoter (f arg) @ qs [(type (src fields ...)) t] ...)
  (define (f arg [original? #t])
    (match arg
      [(struct type (src fields ...))
       (let ([q-src (src->syntax src #f original?)])
         (with-syntax ([@ (syntax-quote-src src)])
           (let-syntax ([qs (syntax-rules ()
                              [(_ expr)
                               (quasisyntax/loc q-src expr)])])
             t)))]
      ...)))

(define (syntax-quote-src s)
  (match s
    [(struct src (a b c d e f g))
     #`(make-src #,a #,b #,c #,d #,e #,f #,g)]))

;; (X -> (syntax X)) * (listof X) -> (syntax (listof X))
(define (syntax-quote-map f xs)
  (with-syntax ([(x ...) (map f xs)])
    #'(list x ...)))

;; (X -> (syntax X)) * (option X) -> (syntax (option X))
(define (syntax-quote-option f x)
  (if x (f x) #'(quote #f)))

(define-quoter (syntax-quote-expr expr) @ qs
  [(expr:ref (src id))
   (qs (make-expr:ref @ #,(syntax-quote-id id)))]
  [(expr:int (src value qualifiers))
   (qs (make-expr:int @ '#,value #,(syntax-quote-map syntax-quote-id qualifiers)))]
  [(expr:float (src value qualifiers))
   (qs (make-expr:float @ '#,value #,(syntax-quote-map syntax-quote-id qualifiers)))]
  [(expr:char (src value wide?))
   (qs (make-expr:char @ '#,value '#,wide?))]
  [(expr:string (src value wide?))
   (qs (make-expr:string @ '#,value '#,wide?))]
  [(expr:compound (src type inits))
   (qs (make-expr:compound @ #,(syntax-quote-map (lambda (init)
                                                   (if (init? init)
                                                       (syntax-quote-init init)
                                                       #`(cons #,(syntax-quote-map syntax-quote-dtor (car init))
                                                               #,(syntax-quote-init (cdr init)))))
                                                 inits)))]
  [(expr:array-ref (src expr offset))
   (qs (make-expr:array-ref @ #,(syntax-quote-expr expr) #,(syntax-quote-expr offset)))]
  [(expr:call (src function args))
   (qs (make-expr:call @ #,(syntax-quote-expr function) #,(syntax-quote-map syntax-quote-expr args)))]
  [(expr:member (src expr label))
   (qs (make-expr:member @ #,(syntax-quote-expr expr) #,(syntax-quote-id label)))]
  [(expr:pointer-member (src expr label))
   (qs (make-expr:pointer-member @ #,(syntax-quote-expr expr) #,(syntax-quote-id label)))]
  [(expr:postfix (src expr op))
   (qs (make-expr:postfix @ #,(syntax-quote-expr expr) #,(syntax-quote-id op)))]
  [(expr:prefix (src op expr))
   (qs (make-expr:prefix @ #,(syntax-quote-id op) #,(syntax-quote-expr expr)))]
  [(expr:cast (src type expr))
   (qs (make-expr:cast @ #,(syntax-quote-type type) #,(syntax-quote-expr expr)))]
  [(expr:sizeof (src term))
   (qs (make-expr:sizeof @ #,(if (type? term) (syntax-quote-type term) (syntax-quote-expr term))))]
  [(expr:unop (src op expr))
   (qs (make-expr:unop @ #,(syntax-quote-id op) #,(syntax-quote-expr expr)))]
  [(expr:binop (src left op right))
   (qs (make-expr:binop @ #,(syntax-quote-expr left) #,(syntax-quote-id op) #,(syntax-quote-expr right)))]
  [(expr:assign (src left op right))
   (qs (make-expr:assign @ #,(syntax-quote-expr left) #,(syntax-quote-id op) #,(syntax-quote-expr right)))]
  [(expr:begin (src left right))
   (qs (make-expr:begin @ #,(syntax-quote-expr left) #,(syntax-quote-expr right)))]
  [(expr:if (src test cons alt))
   (qs (make-expr:if @ #,(syntax-quote-expr test) #,(syntax-quote-expr cons) #,(syntax-quote-expr alt)))])

(define-quoter (syntax-quote-stmt stmt) @ qs
  [(stmt:label (src label stmt))
   (qs (make-stmt:label @ #,(syntax-quote-id label) #,(syntax-quote-stmt stmt)))]
  [(stmt:case (src expr stmt))
   (qs (make-stmt:case @ #,(syntax-quote-expr expr) #,(syntax-quote-stmt stmt)))]
  [(stmt:default (src stmt))
   (qs (make-stmt:default @ #,(syntax-quote-stmt stmt)))]
  [(stmt:block (src items))
   (qs (make-stmt:block @ #,(syntax-quote-map (lambda (item)
                                                (if (decl? item)
                                                    (syntax-quote-decl item)
                                                    (syntax-quote-stmt item)))
                                              items)))]
  [(stmt:expr (src expr))
   (qs (make-stmt:expr @ #,(syntax-quote-expr expr)))]
  [(stmt:if (src test cons alt))
   (qs (make-stmt:if @ #,(syntax-quote-expr test) #,(syntax-quote-stmt cons) #,(syntax-quote-option syntax-quote-stmt alt)))]
  [(stmt:switch (src test body))
   (qs (make-stmt:switch @ #,(syntax-quote-expr test) #,(syntax-quote-stmt body)))]
  [(stmt:while (src test body))
   (qs (make-stmt:while @ #,(syntax-quote-expr test) #,(syntax-quote-stmt body)))]
  [(stmt:do (src body test))
   (qs (make-stmt:do @ #,(syntax-quote-stmt body) #,(syntax-quote-expr test)))]
  [(stmt:for (src init test update body))
   (qs (make-stmt:for @
                      #,(cond
                          [(decl? init) (syntax-quote-decl init)]
                          [(expr? init) (syntax-quote-expr init)]
                          [else #'(quote #f)])
                      #,(syntax-quote-option syntax-quote-expr test)
                      #,(syntax-quote-option syntax-quote-expr update)
                      #,(syntax-quote-stmt body)))]
  [(stmt:goto (src label))
   (qs (make-stmt:goto @ #,(syntax-quote-id label)))]
  [(stmt:continue (src))
   (qs (make-stmt:continue @))]
  [(stmt:break (src))
   (qs (make-stmt:break @))]
  [(stmt:return (src expr))
   (qs (make-stmt:return @ #,(syntax-quote-option syntax-quote-expr expr)))]
  [(stmt:empty (src))
   (qs (make-stmt:empty @))])

(define-quoter (syntax-quote-decl decl) @ qs
  [(decl:typedef (src type declarators))
   (qs (make-decl:typedef @ #,(syntax-quote-type type) #,(syntax-quote-map syntax-quote-decl declarators)))]
  [(decl:vars (src class type declarators))
   (qs (make-decl:vars @
                       #,(syntax-quote-option syntax-quote-id class)
                       #,(syntax-quote-option syntax-quote-type type)
                       #,(syntax-quote-map syntax-quote-decl declarators)))]
  [(decl:formal (src class type declarator))
   (qs (make-decl:formal @
                         #,(syntax-quote-option syntax-quote-id class)
                         #,(syntax-quote-option syntax-quote-type type)
                         #,(syntax-quote-decl declarator)))]
  [(decl:function (src class inline? return formals preamble body))
   (qs (make-decl:function @
                           #,(syntax-quote-option syntax-quote-id class)
                           #,(syntax-quote-option syntax-quote-id inline?)
                           #,(syntax-quote-type return)
                           #,(syntax-quote-map syntax-quote-decl formals)
                           #,(syntax-quote-option (lambda (ls) (syntax-quote-map syntax-quote-decl ls)) preamble)
                           #,(syntax-quote-stmt body)))]
  [(decl:declarator (src id type init))
   (qs (make-decl:declarator @
                             #,(syntax-quote-option syntax-quote-id id)
                             #,(syntax-quote-option syntax-quote-type type)
                             #,(syntax-quote-option syntax-quote-init init)))]
  [(decl:member (src type declarators))
   (qs (make-decl:member @
                         #,(syntax-quote-map syntax-quote-type type)
                         #,(syntax-quote-map syntax-quote-decl declarators)))]
  [(decl:struct-declarator (src id type initializer bit-size))
   (qs (make-decl:struct-declarator @
                                    #,(syntax-quote-option syntax-quote-id id)
                                    #,(syntax-quote-option syntax-quote-type type)
                                    #,(syntax-quote-option syntax-quote-init initializer)
                                    #,(syntax-quote-option syntax-quote-expr bit-size)))])

(define-quoter (syntax-quote-init init) @ qs
  [(init:compound (src elements))
   (qs (make-init:compound @ #,(syntax-quote-map (lambda (elt)
                                                   (if (init? elt)
                                                       (syntax-quote-init elt)
                                                       #`(cons #,(syntax-quote-map syntax-quote-dtor (car elt))
                                                               #,(syntax-quote-init (cdr elt)))))
                                                 elements)))]
  [(init:expr (src expr))
   (qs (make-init:expr @ #,(syntax-quote-expr expr)))])

(define-quoter (syntax-quote-dtor dtor) @ qs
  [(dtor:array (src expr))
   (qs (make-dtor:array @ #,(syntax-quote-expr expr)))]
  [(dtor:member (src label))
   (qs (make-dtor:member @ #,(syntax-quote-id label)))])

(define-quoter (syntax-quote-type type) @ qs
  [(type:primitive (src name))
   (qs (make-type:primitive @ '#,name))]
  [(type:ref (src id))
   (qs (make-type:ref @ '#,id))]
  [(type:struct (src tag fields))
   (qs (make-type:struct @ '#,tag #,(syntax-quote-map syntax-quote-decl fields)))]
  [(type:union (src tag variants))
   (qs (make-type:struct @ '#,tag #,(syntax-quote-map syntax-quote-decl variants)))]
  [(type:enum (src tag variants))
   (qs (make-type:struct @ '#,tag #,(syntax-quote-map (lambda (variant)
                                                        (if (pair? variant)
                                                            #`(cons #,(syntax-quote-id (car variant))
                                                                    #,(syntax-quote-expr (cdr variant)))
                                                            (syntax-quote-id variant)))
                                                      variants)))]
  [(type:array (src base static? qualifiers length star?))
   (qs (make-type:array @
                        #,(syntax-quote-option syntax-quote-type base)
                        '#,static?
                        #,(syntax-quote-map syntax-quote-id qualifiers)
                        #,(syntax-quote-expr length)
                        #,(syntax-quote-option syntax-quote-id star?)))]
  [(type:pointer (src base qualifiers))
   (qs (make-type:pointer @
                          #,(syntax-quote-option syntax-quote-type base)
                          #,(syntax-quote-map syntax-quote-id qualifiers)))]
  [(type:function (src return formals))
   (qs (make-type:function @
                           #,(syntax-quote-option syntax-quote-type return)
                           #,(syntax-quote-map (lambda (formal)
                                                 (if (decl? formal)
                                                     (syntax-quote-decl formal)
                                                     (syntax-quote-id formal)))
                                               formals)))]
  [(type:qualified (src type qualifiers))
   (qs (make-type:qualified @
                            #,(syntax-quote-option syntax-quote-type type)
                            #,(syntax-quote-map syntax-quote-id qualifiers)))])

(define-quoter (syntax-quote-id id) @ qs
  [(id:var (src name))
   (qs (make-id:var @ '#,name))]
  [(id:label (src name))
   (qs (make-id:label @ '#,name))]
  [(id:qualifier (src name))
   (qs (make-id:qualifier @ '#,name))]
  [(id:op (src name))
   (qs (make-id:op @ '#,name))]
  [(id:storage (src class))
   (qs (make-id:storage @ '#,class))]
  [(id:inline (src))
   (qs (make-id:inline @))]
  [(id:ellipsis (src))
   (qs (make-id:ellipsis @))]
  [(id:star (src))
   (qs (make-id:star @))])