adamc@1: (* Copyright (c) 2008, Adam Chlipala
adamc@1:  * All rights reserved.
adamc@1:  *
adamc@1:  * Redistribution and use in source and binary forms, with or without
adamc@1:  * modification, are permitted provided that the following conditions are met:
adamc@1:  *
adamc@1:  * - Redistributions of source code must retain the above copyright notice,
adamc@1:  *   this list of conditions and the following disclaimer.
adamc@1:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@1:  *   this list of conditions and the following disclaimer in the documentation
adamc@1:  *   and/or other materials provided with the distribution.
adamc@1:  * - The names of contributors may not be used to endorse or promote products
adamc@1:  *   derived from this software without specific prior written permission.
adamc@1:  *
adamc@1:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@1:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@1:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@1:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@1:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@1:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@1:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@1:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@1:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@1:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@1:  * POSSIBILITY OF SUCH DAMAGE.
adamc@1:  *)
adamc@1: 
adamc@244: (* Generic printing support code *)
adamc@1: 
adamc@1: structure Print :> PRINT = struct
adamc@1: 
adamc@1: structure SM = TextIOPP
adamc@1: structure PD = PPDescFn(SM)
adamc@1: 
adamc@1: type 'a printer = 'a -> PD.pp_desc
adamc@1: 
adamc@1: fun box ds = PD.hovBox (PD.PPS.Rel 1, ds)
adamc@1: fun parenIf b d =
adamc@1:     if b then
adamc@1:         box [PD.string "(", d, PD.string ")"]
adamc@1:     else
adamc@1:         d
adamc@1: val space = PD.space 1
adamc@1: 
adamc@1: val out = SM.openOut {dst = TextIO.stdOut, wid = 70}
adamc@1: val err = SM.openOut {dst = TextIO.stdErr, wid = 70}
adamc@1: 
adamc@1: fun p_list_sep sep f ls =
adamc@1:     case ls of
adamc@1:         [] => PD.string ""
adamc@1:       | [x] => f x
adamc@1:       | x :: rest =>
adamc@1:         let
adamc@1:             val tokens = foldr (fn (x, tokens) =>
adamc@223:                                    sep :: PD.cut :: f x :: tokens)
adamc@1:                                [] rest
adamc@1:         in
adamc@1:             box (f x :: tokens)
adamc@1:         end
adamc@1: fun p_list f = p_list_sep (box [PD.string ",", space]) f
adamc@1: 
adamc@275: fun p_list_sepi sep f ls =
adamc@275:     case ls of
adamc@275:         [] => PD.string ""
adamc@275:       | [x] => f 0 x
adamc@275:       | x :: rest =>
adamc@275:         let
adamc@275:             val tokens = ListUtil.foldri (fn (n, x, tokens) =>
adamc@275:                                              sep :: PD.cut :: f (n + 1) x :: tokens)
adamc@275:                                          [] rest
adamc@275:         in
adamc@275:             box (f 0 x :: tokens)
adamc@275:         end
adamc@275: 
adamc@1: fun fprint f d = (PD.description (f, d);
adamc@1:                   PD.PPS.flushStream f)
adamc@1: val print = fprint out
adamc@1: val eprint = fprint err
adamc@1: 
adamc@1: fun fpreface f (s, d) =
adamc@1:     fprint f (PD.hovBox (PD.PPS.Rel 0,
adamc@5: 		         [PD.string s, PD.space 1, d, PD.newline]))
adamc@1: 
adamc@1: val preface = fpreface out
adamc@1: val epreface = fpreface err
adamc@1: 
adamc@3: fun fprefaces f s ls =
adamc@3:     let
adamc@3:         val len = foldl (fn ((s, _), best) =>
adamc@3:                             Int.max (size s, best)) 0 ls
adamc@3:     in
adamc@3:         fprint f (PD.string s);
adamc@3:         fprint f PD.newline;
adamc@3:         app (fn (s, d) =>
adamc@3:                 let
adamc@3:                     val s = CharVector.tabulate (len - size s,
adamc@3:                                                  fn _ => #" ")
adamc@3:                             ^ s ^ ": "
adamc@3:                 in
adamc@3:                     fpreface f (s, d)
adamc@3:                 end) ls
adamc@3:     end
adamc@3: 
adamc@3: val prefaces = fprefaces out
adamc@3: val eprefaces = fprefaces err
adamc@3: 
adamc@3: fun fprefaces' f ls =
adamc@1:     let
adamc@1:         val len = foldl (fn ((s, _), best) =>
adamc@1:                             Int.max (size s, best)) 0 ls
adamc@1:     in
adamc@1:         app (fn (s, d) =>
adamc@1:                 let
adamc@1:                     val s = CharVector.tabulate (len - size s,
adamc@1:                                                  fn _ => #" ")
adamc@1:                             ^ s ^ ": "
adamc@1:                 in
adamc@1:                     fpreface f (s, d)
adamc@1:                 end) ls
adamc@1:     end
adamc@1: 
adamc@3: val prefaces' = fprefaces' out
adamc@3: val eprefaces' = fprefaces' err
adamc@1: 
adamc@1: end