#lang scheme/base

(require scheme/list)
(require (file "utilities.scm"))
(require (file "primitives.scm"))

(provide write-rla-value
         current-indent
         current-indent-step
         verbose-rla?)

(define current-indent (make-parameter 0))
(define current-indent-step (make-parameter 2))
(define verbose-rla? (make-parameter #f))

(define current-object-map (make-parameter #f))
(define next-object-number (make-parameter #f))

(define symbol-structs (make-parameter #f))
(define symbol-type '(#%immutable (#%struct (#%builtin "structure") () 1 #f)))

(define (write-rla-value value (port (current-output-port)))
  (void (parameterize ([current-output-port port]
                       [current-object-map (make-hasheq)]
                       [next-object-number 0]
                       [symbol-structs (make-hasheq)])
          (build-object-map value)
          (port-count-lines! port)
          (write-rla-val value))))

(define (symbol->struct sym)
  (if (hash-has-key? (symbol-structs) sym)
      (hash-ref (symbol-structs) sym)
      (begin
        (let ([s `(#%immutable (#%struct ,symbol-type ,(symbol->string sym)))])
          (hash-set! (symbol-structs) sym s)
          s))))

(define (build-object-map value)
  (cond
    [(or (boolean? value) (number? value) (char? value) (null? value)) (void)]
    [(and (pair? value) (eq? (car value) '#%immutable))
      (build-object-map (second value))]
    [else (let* ([objmap (current-object-map)]
                 [in-map (hash-has-key? objmap value)])
            (hash-set! objmap value in-map)
            (unless in-map
              (cond
                [(pair? value)
                  (build-object-map (car value))
                  (build-object-map (cdr value))]
                [(symbol? value)
                  (build-object-map (symbol->struct value))]
                [(vector? value)
                  (for ([item (in-vector value)])
                    (build-object-map item))])))]))

(define hex-digits "0123456789abcdef")

(define (hard-new-line)
  (write-char #\Newline)
  (for ([i (in-range 0 (current-indent))])
    (write-char #\Space)))

(define (req-new-line)
  (if (verbose-rla?)
      (hard-new-line)
      (write-char #\Space)))

(define (opt-new-line)
  (when (verbose-rla?)
    (hard-new-line)))

(define (write-hex-char ord)
  (write-string "\\x")
  (write-char (string-ref hex-digits (quotient  ord 16)))
  (write-char (string-ref hex-digits (remainder ord 16))))

(define (write-hex-byte ord)
  (write-string "0x")
  (write-char (string-ref hex-digits (quotient  ord 16)))
  (write-char (string-ref hex-digits (remainder ord 16))))

(define (write-rla-string value)
  (write-char #\")
  (for ([ch (in-string value)])
    (cond
      [(and (eq? ch #\"))
         (write-string "\\\"")]
      [(and (eq? ch #\\))
         (write-string "\\\\")]
      [(and (< (char->integer ch) 128) (char-graphic? ch))
         (write-char ch)]
      [else
         (write-hex-char (char->integer ch))]))
  (write-char #\"))

(define (write-rla-struct value)
  (write-string "#S(")
  (write-rla-val (second value))
  (for ([slotval (in-list (cddr value))])
    (write-char #\Space)
    (write-rla-val slotval))
  (write-char #\)))

(define (write-instance-string inst-vars)
  (write-string "#@\"")
  (for ([var (in-list inst-vars)])
    (write-hex-char (variable->code var)))
  (write-char #\"))

(define (write-rla-bytecode+tail-call forms)
  (define (write-tail-call tc-form)
    (req-new-line)
    (write-string "#@\"")
    (for ([var (in-list (cdr tc-form))])
      (write-hex-char (variable->code var)))
    (write-char #\")
    (when (verbose-rla?)
      (write-char #\;)
      (for ([var (in-list (cdr tc-form))])
        (write-char #\Space)
        (write var))))

  (let-values ([(line col pos) (port-next-location (current-output-port))])
    (parameterize ([current-indent col])
      (write-string "#@\"")
      (if (eq? (first (third (first forms))) '#%tail-call)
          (begin
            (write-char #\")
            (write-tail-call (third (first forms))))
          (let iter ([forms forms])
            (map (lambda (x) (write-hex-char x))
                 (statement->code (car forms)))
            (if (eq? (first (third (second forms))) '#%tail-call)
                (begin
                  (if (verbose-rla?)
                      (begin
                        (write-string "\"; ")
                        (write (first forms)))
                      (write-char #\"))
                  (write-tail-call (third (second forms))))
                (begin
                  (when (verbose-rla?)
                    (write-string "\\; ")
                    (write (car forms))
                    (hard-new-line)
                    (write-string "   "))
                  (iter (cdr forms)))))))))

(define (write-rla-function value)
  (define template? (eq? (first value) '#%template))
  (let-values ([(line col pos) (port-next-location (current-output-port))])
    (parameterize ([current-indent col])
      (write-string "#@#S(")
      (if (eq? (first value) '#%template)
          (write-string "#=\"template\"")
          (write-string "#=\"lambda\""))
      (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
        (req-new-line)
        (write-string "#@#(")
        (unless (null? (second value))
          (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
            (opt-new-line)
            (write-rla-val (first (second value)))
            (for ([global (in-list (cdr (second value)))])
              (req-new-line)
              (write-rla-val global)))
          (opt-new-line))
        (write-string ")")
        (req-new-line)
        (if template?
            (write-instance-string (third value))
            (begin
              (write-string "#@#(")
              (unless (null? (third value))
                (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
                  (opt-new-line)
                  (write-rla-val (first (third value)))
                  (for ([instance (in-list (cdr (third value)))])
                    (req-new-line)
                    (write-rla-val instance)))
                (opt-new-line))
              (write-string ")")))
        (req-new-line)
        (write-rla-bytecode+tail-call (cddr (fourth value))))
      (opt-new-line))
    (write-string ")")))

(define (write-rla-val value)
  (let ([ref (hash-ref (current-object-map) value #f)])
    (cond
      [(number? ref)
        (write-string "#=")
        (write ref)]
      [ref
        (let ([objnum (next-object-number)])
          (hash-set! (current-object-map) value objnum)
          (next-object-number (+ 1 objnum))
          (write-char #\#)
          (write objnum)
          (write-char #\=))
          (write-plain-rla-val value)]
      [else
          (write-plain-rla-val value)])))

(define (write-plain-rla-val value)
  (cond
    [(or (boolean? value) (number? value))
       (write value)]
    [(char? value)
       (write (char->integer value))]
    [(symbol? value)
       (write-plain-rla-val (symbol->struct value))]
    [(string? value)
       (write-rla-string value)]
    [(and (pair? value) (memq (car value) '(#%builtin)))
       (write-string "#=")
       (write-rla-string (second value))]
    [(and (pair? value) (memq (car value) '(#%include)))
       (write-string "#i")
       (write-rla-string (second value))]
    [(and (pair? value) (memq (car value) '(#%immutable)))
       (unless (number? (hash-ref (current-object-map) (second value) #f))
         (write-string "#@"))
       (write-rla-val (second value))]
    [(and (pair? value) (memq (car value) '(#%struct)))
       (write-rla-struct value)]
    [(and (pair? value) (memq (car value) '(#%lambda #%template)))
       (write-rla-function value)]
    [(vector? value)
       (write-string "#(")
       (unless (zero? (vector-length value))
         (write-rla-val (vector-ref value 0)))
       (for ([i (in-range 1 (vector-length value))])
         (write-char #\Space)
         (write-rla-val (vector-ref value i)))
       (write-string ")")]
    [(null? value)
       (write-string "()")]
    [(pair? value)
       (write-string "(")
       (let iter ([lst value])
         (write-rla-val (car lst))
         (cond
           [(null? (cdr lst))
              (write-string ")")]
           [(and (pair? (cdr lst)) (not (hash-ref (current-object-map) (cdr lst) #f)))
              (write-char #\Space)
              (iter (cdr lst))]
           [else
              (write-string " . ")
              (write-rla-val (cdr lst))
              (write-string ")")]))]
    [else (error "Don't know how to write Rosella syntax for:" value)]))

(define (variable->code var)
  (or (let ([index (find var transient-variables)])
        (and index (+ #x00 index)))
      (let ([index (find var global-variables)])
        (and index (+ #x80 index)))
      (let ([index (find var instance-variables)])
        (and index (+ #xc0 index)))
      (let ([index (find var '(#%f #%nil #%undef))])
        (and index (+ #xf0 index)))
      (let ([index (find var '(#%self #%globals #%inst #%argv #%kw-args #%kw-vals #%ctx #%k))])
        (and index (+ #xf8 index)))
      (error "No bytecode for variable:" var)))

(define (statement->code form)
  (let ([vform (third form)])  ; (#%set! #%tNN vform)
    (case (length (cdr vform))
      [(1) (let ([item (assoc (first vform) unary-primitives)])
             (or item (error "Invalid unary primitive:" vform))
             (list #x00
                   #x00
                   (second item)
                   (variable->code (second vform))))]
      [(2) (let ([item (assoc (first vform) binary-primitives)])
             (or item (error "Invalid binary primitive:" vform))
             (list #x00
                   (second item)
                   (variable->code (second vform))
                   (variable->code (third vform))))]
      [(3) (let ([item (assoc (first vform) ternary-primitives)])
             (or item (error "Invalid ternary primitive:" vform))
             (if (eq? (first vform) '#%vector-ref-immed)
                 (list (second item)
                       (variable->code (second vform))
                       (third  vform)
                       (fourth vform))
                 (list (second item)
                       (variable->code (second vform))
                       (variable->code (third  vform))
                       (variable->code (fourth vform)))))]
      [else (error "Unsupported form:" vform)])))

; vim:set sw=2 expandtab: