#!/usr/bin/env newlisp

;; @module prettyprint-css.lsp
;; @description experimental formatting/colouring for newLISP source
;; @version 0.0.1 of 2007-11-30 13:53:01 
;; @author cormullion

; format the text using some simple rules
; restrictions: comments at the end of a line are moved to the next line
; usage 
; (context MAIN)
; (load {tokenizer.lsp})
; (Pretty:pretty-output (Tokenize (read-file {source-file.lsp})))

(context 'Pretty)

(set 'depth 0 'tab-width 4 'output-buffer {} 'html-format true)

(define (format-code-element k) 
; return list of three strings: startmarkup, element, end markup
 (let ((result '())
    (code-element-string k)
    ) 
  (if (or 
      (= k "fn" ) 
      (= k "lambda")
      (= k "lambda-macro")) 
    (set 'result (list {<span class="la">} code-element-string {</span>}))  
    (cond
     ((= k "'")
           (set 'result (list {<span class="q">} code-element-string {</span>})))
     (true
         (set 'type-number (& 15 (nth 1 (dump (eval-string k)))))     
         (case type-number
           (0   (set 'result (list  {<span class="nl">}  code-element-string {</span>}))) ; nil
           (1   (set 'result (list  {<span class="t">}   code-element-string {</span>}))) ; true
           (2   (set 'result (list  {<span class="i">}   code-element-string {</span>}))) ; int
           (3   (set 'result (list  {<span class="f">}   code-element-string {</span>}))) ; float
           (4   (set 'result (list  {<span class="s">}   code-element-string {</span>}))) ; string
           (5   (set 'result (list  {<span class="sy">}  code-element-string {</span>}))) ; sym
           (6   (set 'result (list  {<span class="ct">}  code-element-string {</span>}))) ; ctx
           (7   (set 'result (list  {<span class="p">}   code-element-string {</span>}))) ; pri
           (8   (set 'result (list  {<span class="p1">}  code-element-string {</span>}))) ; pri
           (9   (set 'result (list  {<span class="p2">}  code-element-string {</span>}))) ; pri
           (10  (set 'result (list  {<span class="q">}   code-element-string {</span>}))) ; quote
           (11  (set 'result (list  {<span class="l">}   code-element-string {</span>}))) ; list
           (12  (set 'result (list  {<span class="la">}  code-element-string {</span>}))) ; lambda
           (13  (set 'result (list  {<span class="ma">}  code-element-string {</span>}))) ; macro
           (14  (set 'result (list  {<span class="a">}   code-element-string {</span>}))) ; array
           (true (set 'result (list {<span class="o">}   code-element-string {</span>})))))))
  result))

(define (tab)
  (dup { } (- (* depth tab-width) 1)))

(define (escape-html txt)
 (if txt
  (begin
   (replace {&} txt {&amp;} 0)
   (replace {<} txt {&lt;} 0)
   (replace {>} txt {&gt;} 0)))
 txt)

(define (output start-markup s end-markup) 
; push the string into a buffer
  (if html-format
     (set 's (string start-markup (escape-html s) end-markup))
     (set 's (string   s )))
  (push s output-buffer -1))
   
(define (pretty-output list-of-tokens (use-CSS true))
  (set 'depth 0 'tab-width 4 'output-buffer {} 'html-format use-CSS)
  (dolist (t list-of-tokens)   
   (set 'type 
    (first t)) 
   (set 'data 
    (last t)) 
   (set 'previous-type 
    (first 
      (list-of-tokens 
       (- $idx 1)))) 
   (set 'previous-data 
    (last 
      (list-of-tokens 
       (- $idx 1)))) 
   (cond 
    ((= type "right-paren")
      (if (and (= previous-type "comment") (>= depth 1))
       (output "" "" ""))
      ; add right paren to stack of previous
      (if (and (= previous-type "right-paren") (>= depth 1))
       (output {<span class="pr">} {)} {</span>})
       (output {<span class="pr">} {)} {</span>}))
      (if (<= depth 1) 
       (output "" "\n" "") 
       (output "" "" "")) 
      (if (<= depth 0)
        (output "" "?" ""))
      (dec 'depth)
      ) 
    ((= type "left-paren" )   
      ; no newline/indent before left paren ...
      (if (not 
         (or 
           ; not after some functions  
           (find previous-data '("define" "let" "letn" "set" "lambda" "fn" "push" "'" "if" "(" "dolist" "unless" "for" "while" "dotree")) 
           ; not if previous line was a comment
           (= previous-type "comment")
           (= previous-type "white-space")
           ; and not if we're following a very short function/operator
           (and 
                (<= (length previous-data) 2) 
                (= previous-type "code")))
          ; newline and indent...
           (begin
             (output "" "\n" "")
             (output "" (tab) ""))))
      ; no space if following left paren or ' or comment
      (if (or 
             (= previous-type "left-paren") 
             (= previous-data "'" )
             (= previous-type "comment")
             (= depth 0))         
         (output "" "" "")
         (output "" " " ""))

      (output (string {<span class="pr">}) {(} {</span>}) 
      (inc 'depth))
      
    ((and (= type "comment") (!= data ""))
        ; newline before comment unless the shebang line
        (if (not 
            (or (starts-with data {#!/usr/bin})
                (= previous-type "comment")
                (= previous-type "white-space")
                ))
            (output "" "\n" ""))
        
        (if (starts-with data ";;" )
           ; two or more semicolons, so start at beginning of line 
           (begin 
               (output {<span class="c">} data (string {</span>}))
               (output {} "\n" {}))
           ; other comments start indented at current level
           (begin
             ; indent to current level
             (if (not (= previous-type "white-space"))
                 (output ""  (tab)  ""))
             ; output the comment
             (output {<span class="c">} data (string {</span>}))
             ; start the next line, and indent to current level again
             ; ready for next
             (output "" (string "\n" (tab)) "")
             )))
         
    ((= type "code" ) 
      (cond 
       ((= data "'")
         (output "" " " "")
         (apply output (format-code-element data )))
       ((= data ":")
         (apply output (format-code-element data)))        
       ((or 
            (= previous-type "left-paren" ) 
            (= previous-data ":" ) 
            (= previous-data "'" )) 
         (output "" "" "")
         (apply output (format-code-element data)))      
       (true 
           (output "" " " "")
           (apply output (format-code-element data )))))

    ((= type "braced-string")
      (if (not (= previous-type "left-paren"))
              (output "" " " ""))
      (apply output (list  (string {<span class="s">}) data (string {</span>}))))
       
    ((= type "quoted-string")
      ; space before the string/double quote char
      (if (not (= previous-type "left-paren"))
              (output "" " " ""))
      (apply output  (list (string {<span class="s">}) data (string {</span>})))) 
      
    ((= type "bracketed-string" ) 
      ; space before
      (if (not (= previous-type "left-paren"))
              (output "" " " ""))
      (apply output (list (string {<span class="s">}) data {</span>})))))
   output-buffer
   )

; eof