;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
;;;; 	Copyright (C) 2001, 2004, 2006, 2009, 2010,
;;;;      2012, 2013, 2014, 2023 Free Software Foundation, Inc.
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; 
(define-module (ice-9 pretty-print)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 soft-ports)
  #:use-module (ice-9 textual-ports)
  #:export (pretty-print
            truncated-print))

(define* (call-with-truncating-output-string proc success failure #:key
                                             (initial-column 0)
                                             (max-column 79)
                                             (allow-newline? #f))
  (define length 0)
  (define strs '())
  (define tag (make-prompt-tag))
  (define (write-string str)
    (set! length (+ length (string-length str)))
    (set! strs (cons str strs))
    (when (or (< (- max-column initial-column) length)
              (and (not allow-newline?)
                   (not (zero? (port-line port)))))
      (abort-to-prompt tag)))
  (define port
    (make-soft-port #:id "truncating-output-port"
                    #:write-string write-string))
  (call-with-prompt
   tag
   (lambda ()
     (proc port)
     (close port)
     (success (string-concatenate-reverse strs)))
   (lambda (_)
     (failure (string-concatenate-reverse strs)))))