Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/smlnj-lib/PP/examples/old-pp.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-lib/PP/examples/old-pp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 104 - (view) (download)

1 : monnier 104 (* old-pp.sml
2 :     *
3 :     * COPYRIGHT (c) 1998 Bell Labs, Lucent Technologies.
4 :     *
5 :     * An implementation of the SML/NJ's PP interface.
6 :     *)
7 :    
8 :     signature OLD_PRETTYPRINT =
9 :     sig
10 :     type ppstream
11 :     type ppconsumer = {
12 :     consumer : string -> unit,
13 :     linewidth : int,
14 :     flush : unit -> unit
15 :     }
16 :    
17 :     datatype break_style = CONSISTENT | INCONSISTENT
18 :    
19 :     exception PP_FAIL of string
20 :    
21 :     val mk_ppstream : ppconsumer -> ppstream
22 :     val dest_ppstream : ppstream -> ppconsumer
23 :     val add_break : ppstream -> int * int -> unit
24 :     val add_newline : ppstream -> unit
25 :     val add_string : ppstream -> string -> unit
26 :     val begin_block : ppstream -> break_style -> int -> unit
27 :     val end_block : ppstream -> unit
28 :     val clear_ppstream : ppstream -> unit
29 :     val flush_ppstream : ppstream -> unit
30 :     val with_pp : ppconsumer -> (ppstream -> unit) -> unit
31 :     val pp_to_string : int -> (ppstream -> 'a -> unit) -> 'a -> string
32 :    
33 :     end;
34 :    
35 :     structure OldPrettyPrint :> OLD_PRETTYPRINT =
36 :     struct
37 :    
38 :     type ppconsumer = {
39 :     consumer : string -> unit,
40 :     linewidth : int,
41 :     flush : unit -> unit
42 :     }
43 :    
44 :     structure Dev =
45 :     struct
46 :     type device = ppconsumer
47 :     type style = unit
48 :     fun sameStyle _ = true
49 :     fun pushStyle _ = ()
50 :     fun popStyle _ = ()
51 :     fun defaultStyle _ = ()
52 :     fun depth _ = NONE
53 :     fun lineWidth {consumer, linewidth, flush} = SOME linewidth
54 :     fun textWidth _ = NONE
55 :     fun space ({consumer, linewidth, flush}, n) =
56 :     consumer (StringCvt.padLeft #" " n "")
57 :     fun newline {consumer, linewidth, flush} = consumer "\n"
58 :     fun string ({consumer, linewidth, flush}, s) = consumer s
59 :     fun char ({consumer, linewidth, flush}, c) = consumer(str c)
60 :     fun flush {consumer, linewidth, flush} = flush()
61 :     end
62 :    
63 :     structure PP = PPStreamFn(structure Token = StringToken structure Device = Dev)
64 :    
65 :     datatype ppstream = STRM of {
66 :     consumer : ppconsumer,
67 :     strm : PP.stream
68 :     }
69 :    
70 :     datatype break_style = CONSISTENT | INCONSISTENT
71 :    
72 :     exception PP_FAIL of string
73 :    
74 :     fun mk_ppstream ppc = STRM{
75 :     consumer = ppc,
76 :     strm = PP.openStream ppc
77 :     }
78 :     fun dest_ppstream (STRM{consumer, ...}) = consumer
79 :     fun add_break (STRM{strm, ...}) (nsp, offset) =
80 :     PP.break strm {nsp=nsp, offset=offset}
81 :     fun add_newline (STRM{strm, ...}) = PP.newline strm
82 :     fun add_string (STRM{strm, ...}) s = PP.string strm s
83 :     fun begin_block (STRM{strm, ...}) CONSISTENT indent =
84 :     PP.openHVBox strm (PP.Rel indent)
85 :     | begin_block (STRM{strm, ...}) INCONSISTENT indent =
86 :     PP.openHOVBox strm (PP.Rel indent)
87 :     fun end_block (STRM{strm, ...}) = PP.closeBox strm
88 :     fun clear_ppstream(STRM{strm, ...}) =
89 :     raise Fail "clear_ppstream not implemented"
90 :     fun flush_ppstream (STRM{strm, ...}) = PP.flushStream strm
91 :     fun with_pp ppc f = let
92 :     val (ppStrm as (STRM{strm, ...})) = mk_ppstream ppc
93 :     in
94 :     f ppStrm;
95 :     PP.closeStream strm
96 :     end
97 :     fun pp_to_string wid ppFn obj = let
98 :     val l = ref ([] : string list)
99 :     fun attach s = l := s :: !l
100 :     in
101 :     with_pp {
102 :     consumer = attach, linewidth = wid, flush = fn()=>()
103 :     } (fn ppStrm => ppFn ppStrm obj);
104 :     String.concat(List.rev(!l))
105 :     end
106 :    
107 :     end;
108 :    

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0