#lang scheme/base

(require scheme/match
         scheme/path
         parser-tools/lex)
(require (for-syntax scheme/base))

(provide (except-out (all-defined-out)
                     src->list list->src src-path->datum stx-for-original-property
                     expr-src stmt-src decl-src init-src dtor-src type-src id-src)
         (rename-out [expr-src* expr-src]
                     [stmt-src* stmt-src]
                     [decl-src* decl-src]
                     [init-src* init-src]
                     [dtor-src* dtor-src]
                     [type-src* type-src]
                     [id-src* id-src]))

(define marshall-source-locations
  (make-parameter 'abstract
                  (lambda (v)
                    (unless (memq v '(abstract write none))
                      (raise-type-error 'marshall-source-locations
                                        "'abstract, 'write, or 'none"
                                        v))
                    v)))

(define-struct src (start end path)
  #:property prop:custom-write
  (lambda (src port write?)
    (case (marshall-source-locations)
      [(abstract) (display "#<src>" port)]
      [(write) (write-src src port)]
      [(none) (write #f port)])))

(define (src->list s)
  (match s
    [(struct src ((struct position (start-offset start-line start-col))
                  (struct position (end-offset end-line end-col))
                  path))
     (list start-offset
           start-line
           start-col
           end-offset
           end-line
           end-col
           (src-path->datum path))]
    [_ s]))

;; This syntax object will have the syntax-original? property. It can be used
;; with datum->syntax-object to give subsequent syntax objects this property.
(define stx-for-original-property (read-syntax #f (open-input-string "original")))

;; region->syntax : src [boolean] -> syntax
(define (src->syntax src [datum '...] [original? #t])
  (let ([src (list->src src)])
    (datum->syntax #f
                   datum
                   (list (src-path src)
                         (position-line (src-start src))
                         (position-col (src-start src))
                         (position-offset (src-start src))
                         (- (position-offset (src-end src)) (position-offset (src-start src))))
                   (and original? stx-for-original-property))))

(define (id->syntax id)
  (src->syntax (id-src id) (id-name id)))

(define (src-path->datum path)
  (if (path? path)
      (some-system-path->string path)
      path))

(define (list->src src)
  (match src
    [(list start-offset start-line start-col end-offset end-line end-col path)
     (make-src (make-position start-offset start-line start-col)
               (make-position end-offset end-line end-col)
               (string->some-system-path path))]
    [_ src]))

(define (write-src src port)
  (write (src->list src) port))

;; position position ... -> position
(define (position-max pos . poss)
  (cond
    [(null? poss) pos]
    [(> (position-offset pos) (position-offset (car poss)))
     (apply position-max pos (cdr poss))]
    [else (apply position-max poss)]))

;; position position ... -> position
(define (position-min pos . poss)
  (cond
    [(null? poss) pos]
    [(< (position-offset pos) (position-offset (car poss)))
     (apply position-min pos (cdr poss))]
    [else (apply position-min poss)]))

;; src src ... -> src
(define (src-range src . srcs)
  (let ([src (list->src src)]
        [srcs (map list->src srcs)])
    (make-src (apply position-min (src-start src) (map src-start srcs))
              (apply position-max (src-end src) (map src-end srcs))
              (src-path src))))

(define-syntax (@ stx)
  (syntax-case stx ()
    [(_ end)
     #'(@ 1 end)]
    [(_ start end)
     (with-syntax ([start-pos (datum->syntax
                               #'end
                               (string->symbol
                                (format "$~a-start-pos" (syntax->datum #'start))))]
                   [end-pos (datum->syntax
                             #'end
                             (string->symbol
                              (format "$~a-end-pos" (syntax->datum #'end))))])
       #'(make-src start-pos end-pos (file-path)))]))

(define (write-ast ast [port (current-output-port)])
  (parameterize ([marshall-source-locations 'write])
    (write ast port)))

;; =============================================================================
;; EXPRESSIONS
;; =============================================================================

(define-struct expr (src) #:prefab)

(define expr-src*
  (procedure-rename (compose list->src expr-src)
                    'expr-src))

(define-struct (expr:ref            expr) (id) #:prefab)
(define-struct (expr:int            expr) (value qualifiers) #:prefab)
(define-struct (expr:float          expr) (value qualifiers) #:prefab)
(define-struct (expr:char           expr) (value wide?) #:prefab)
(define-struct (expr:string         expr) (value wide?) #:prefab)
(define-struct (expr:compound       expr) (type inits) #:prefab)
(define-struct (expr:array-ref      expr) (expr offset) #:prefab)
(define-struct (expr:call           expr) (function arguments) #:prefab)
(define-struct (expr:member         expr) (expr label) #:prefab)
(define-struct (expr:pointer-member expr) (expr label) #:prefab)
(define-struct (expr:postfix        expr) (expr op) #:prefab)
(define-struct (expr:prefix         expr) (op expr) #:prefab)
(define-struct (expr:cast           expr) (type expr) #:prefab)
(define-struct (expr:sizeof         expr) (term) #:prefab)
(define-struct (expr:unop           expr) (op expr) #:prefab)
(define-struct (expr:binop          expr) (left op right) #:prefab)
(define-struct (expr:assign         expr) (left op right) #:prefab)
(define-struct (expr:begin          expr) (left right) #:prefab)
(define-struct (expr:if             expr) (test cons alt) #:prefab)


;; =============================================================================
;; STATEMENTS
;; =============================================================================

(define-struct stmt (src) #:prefab)

(define stmt-src*
  (procedure-rename (compose list->src stmt-src)
                    'stmt-src))

(define-struct (stmt:label    stmt) (label stmt) #:prefab)
(define-struct (stmt:case     stmt) (expr stmt) #:prefab)
(define-struct (stmt:default  stmt) (stmt) #:prefab)
(define-struct (stmt:block    stmt) (items) #:prefab)
(define-struct (stmt:expr     stmt) (expr) #:prefab)
(define-struct (stmt:if       stmt) (test cons alt) #:prefab)
(define-struct (stmt:switch   stmt) (test body) #:prefab)
(define-struct (stmt:while    stmt) (test body) #:prefab)
(define-struct (stmt:do       stmt) (body test) #:prefab)
(define-struct (stmt:for      stmt) (init test update body) #:prefab)
(define-struct (stmt:goto     stmt) (label) #:prefab)
(define-struct (stmt:continue stmt) () #:prefab)
(define-struct (stmt:break    stmt) () #:prefab)
(define-struct (stmt:return   stmt) (result) #:prefab)
(define-struct (stmt:empty    stmt) () #:prefab)


;; =============================================================================
;; DECLARATIONS
;; =============================================================================

(define-struct decl (src) #:prefab)

(define decl-src*
  (procedure-rename (compose list->src decl-src)
                    'decl-src))

(define-struct (decl:typedef    decl) (type declarators) #:prefab)
(define-struct (decl:vars       decl) (storage-class type declarators) #:prefab)
(define-struct (decl:formal     decl) (storage-class type declarator) #:prefab)
(define-struct (decl:function   decl) (storage-class inline? return-type formals preamble body) #:prefab)
(define-struct (decl:declarator decl) (id type initializer) #:prefab)
(define-struct (decl:member     decl) (id declarators) #:prefab)


;; =============================================================================
;; INITIALIZERS
;; =============================================================================

(define-struct init (src) #:prefab)

(define init-src*
  (procedure-rename (compose list->src init-src)
                    'init-src))

;; (listof (union init (cons dtor init)))
(define-struct (init:array init) (elements) #:prefab)
(define-struct (init:expr  init) (expr) #:prefab)


;; =============================================================================
;; DESIGNATORS
;; =============================================================================

(define-struct dtor (src) #:prefab)

(define dtor-src*
  (procedure-rename (compose list->src dtor-src)
                    'dtor-src))

(define-struct (dtor:array  dtor) (expr) #:prefab)
(define-struct (dtor:member dtor) (label) #:prefab)


;; =============================================================================
;; TYPES
;; =============================================================================

(define-struct type (src) #:prefab)

(define type-src*
  (procedure-rename (compose list->src type-src)
                    'type-src))

(define-struct (type:primitive type) (name) #:prefab)
(define-struct (type:ref       type) (id) #:prefab)
(define-struct (type:struct    type) (tag fields) #:prefab)
(define-struct (type:union     type) (tag variants) #:prefab)
(define-struct (type:enum      type) (tag variants) #:prefab)
(define-struct (type:array     type) (base static? qualifiers length star?) #:prefab)
(define-struct (type:pointer   type) (base qualifiers) #:prefab)
(define-struct (type:function  type) (return formals) #:prefab)
(define-struct (type:qualified type) (type qualifiers) #:prefab)


;; =============================================================================
;; IDENTIFIERS
;; =============================================================================

(define-struct id (src name) #:prefab)

(define id-src*
  (procedure-rename (compose list->src id-src)
                    'id-src))

#|

;(define-struct src (file line col span pos) #:transparent)

(define-struct expr:lit (type value) #:prefab)
(define-struct expr:binop (op left right) #:prefab)
(define (expr? x)
  (or (expr:lit? x)
      (expr:binop? x)))

(define-struct decl:type:def (root defs) #:prefab)
(define-struct decl:type:tagged (type) #:prefab)
(define (decl? x)
  (or (decl:type:def? x)
      (decl:type:tagged? x)))

(define-struct type:ref (name) #:prefab)
(define-struct type:struct (tag fields) #:prefab)
(define-struct type:union (tag variants) #:prefab)
(define-struct type:enum (tag variants) #:prefab)
(define-struct type:array (type size) #:prefab)
(define-struct type:pointer (type) #:prefab)
(define-struct type:function (return args) #:prefab)
(define (type? x)
  (or (type:ref? x)
      (type:struct? x)
      (type:union? x)
      (type:enum? x)
      (type:array? x)
      (type:pointer? x)
      (type:function? x)))
|#