#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do pp)' -s $0 "$@" # -*-scheme-*-
!#
;;; pp

;; Copyright (C) 2007, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: pp [options] FILE...
;;
;; Pretty print contents of FILE... to stdout.
;; The contents are read as "normal" Scheme sexps.
;;
;; Options:
;;  -p, --preserve-comments  -- output top-level whitespace and
;;                              comments (including a script's
;;                              initial #!...!# header) undisturbed
;;  -s, --sed SCRIPT         -- do "sed SCRIPT FILE" for input
;;  -k, --keyword-hack       -- do ‘s/#:/:#/g’ for input and
;;                              ‘s/:#/#:/g’ for output (yuk!)

;;; Code:

(define-module (ttn-do pp)
  #:export (main pp)
  #:use-module ((ttn-do zzz 0gx forms-from) #:select (forms<-port))
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ice-9 pretty-print) #:select (pretty-print))
  #:autoload (ice-9 popen) (open-input-pipe
                            open-output-pipe)
  #:use-module ((ttn-do zzz personally) #:select (FE fs)))

(cond-expand (pretty-print-can-escape-strings
              (define (pretty-pretty-print x . rest)
                (apply pretty-print x #:escape-strings? #t rest)))
             (else
              (define pretty-pretty-print pretty-print)))

;; Pretty-print @var{sexp} to the current output port,
;; or @var{port} if specified.
;; If the underlying Guile supports it, all strings in the
;; output have certain characeters @dfn{escaped}, e.g., with
;; @samp{#\newline} represented as @samp{\n}
;; (two chars: @code{#\\} and @code{#\n}).
;;
;;-args: (- 1 0 port)
;;
(define (pp sexp . opts)
  (apply pretty-pretty-print sexp opts))

(define (slow p)
  ;; portions taken from SLIB ppfile.scm ‘pprint-filter-file’
  (letrec ((loop (lambda (c)
                   (cond ((eof-object? c))
                         ((char-whitespace? c)
                          (display (read-char p))
                          (loop (peek-char p)))
                         ((char=? #\; c)
                          (cmt c))
                         ((char=? #\# c)
                          (hb c))
                         (else (sx)))))
           (hb (lambda (c)
                 (let ((nc (begin (read-char p) (peek-char p))))
                   (cond ((not (char=? #\! nc))
                          (unread-char c)
                          (sx))
                         (else
                          (display c)
                          (read-char p)
                          (let hb2 ((last nc) (next (read-char p)))
                            (display last)
                            (cond ((and (char=? #\! last)
                                        (char=? #\# next))
                                   (display next)
                                   (loop (peek-char p)))
                                  (else
                                   (hb2 next (read-char p))))))))))
           (cmt (lambda (c)
                  (cond ((eof-object? c))
                        ((char=? #\newline c)
                         (display (read-char p))
                         (loop (peek-char p)))
                        (else
                         (display (read-char p))
                         (cmt (peek-char p))))))
           (sx (lambda ()
                 (let ((sexp (read p)))
                   (cond ((eof-object? sexp))
                         (else
                          (pp sexp)
                          ;; pretty-print seems to have extra newline
                          (let ((c (peek-char p)))
                            (cond ((eqv? #\newline c)
                                   (read-char p)
                                   (set! c (peek-char p))))
                            (loop c))))))))
    (loop (peek-char p))))

(define (fast p)
  (FE (forms<-port p) pp))

(define (pp/qop qop)
  (define (open-filtering-proc script)
    (lambda (filename)
      (open-input-pipe (fs "sed '~A' ~A" script filename))))
  (let ((open (or (and (qop 'keyword-hack)
                       (open-filtering-proc "s/#:/:#/g"))
                  (qop 'sed open-filtering-proc)
                  open-input-file))
        (proc (if (qop 'preserve-comments)
                  slow
                  fast)))
    (and (qop 'keyword-hack)
         (set-current-output-port (open-output-pipe "sed 's/:#/#:/g'")))
    (FE (qop '()) (lambda (filename)
                    (let ((port (open filename)))
                      (proc port)
                      (close-port port))))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.1")
                   (help . commentary)))
  (pp/qop
   (qop<-args
    args '((sed (single-char #\s) (value #t))
           (keyword-hack (single-char #\k))
           (preserve-comments (single-char #\p))))))

;;; pp ends here