1 (* Copyright (C
) 2009,2014,2017 Matthew Fluet
.
2 * Copyright (C
) 1999-2006 Henry Cejtin
, Matthew Fluet
, Suresh
3 * Jagannathan
, and Stephen Weeks
.
5 * MLton is released under a BSD
-style license
.
6 * See the file MLton
-LICENSE for details
.
9 structure Layout
: LAYOUT
=
12 structure Out
= Outstream0
13 structure Int = Pervasive
.Int
14 val detailed
= ref
false
16 fun switch
{detailed
= d
,normal
= n
} x
=
17 if !detailed
then d x
else n x
19 structure String = String0
21 datatype t
= T
of {length
: int,
27 | Align
of {force
: bool, rows
: t list
}
31 fun length (T
{length
, ...}) = length
33 val empty
= T
{length
= 0, tree
= Empty
}
35 fun isEmpty (T
{length
= 0, ...}) = true
41 | _
=> T
{length
= String.size s
, tree
= String s
}
43 fun fold (l
, b
, f
) = foldl f b l
46 let val len
= fold (ts
, 0, fn (t
,n
) => n
+ length t
)
49 | _
=> T
{length
= len
, tree
= Sequence ts
}
59 let val (ts
, n
) = loop ts
62 | n
' => (t
:: ts
, n
+ n
' + 1)
64 val (ts
, len
) = loop ts
67 | _
=> T
{length
= len
- 1, tree
= Align
{force
= force
, rows
= ts
}}
71 val mayAlign
= make
false
74 fun indent (t
, n
) = T
{length
= length t
, tree
= Indent (t
, n
)}
76 fun compact t
= T
{length
= length t
, tree
= Compact t
}
78 fun blanks (n
: int): string =
81 fun outputTree (t
, out
) =
82 let val print
= Out
.outputc out
83 fun loop (T
{tree
, length
}) =
85 ; print (Int.toString length
)
88 Empty
=> print
"Empty"
89 |
String s
=> (print
"(String "; print s
; print
")")
90 | Sequence ts
=> loops ("Sequence", ts
)
91 | Align
{rows
, ...} => loops ("Align", rows
)
92 |
Indent (t
, n
) => (print
"(Indent "
93 ; print (Int.toString n
)
97 | Compact t
=> (print
"(Compact "
100 and loops (s
, ts
) = (print
"("
102 ; app (fn t
=> (print
" " ; loop t
)) ts
109 fun loop (T
{tree
, ...}, accum
) =
112 |
String s
=> s
:: accum
113 | Sequence ts
=> fold (ts
, accum
, loop
)
114 | Align
{rows
, ...} =>
118 fold (ts
, loop (t
, accum
), fn (t
, ac
) =>
119 loop (t
, " " :: ac
)))
120 |
Indent (t
, _
) => loop (t
, accum
)
121 | Compact t
=> loop (t
, accum
)
123 String.concat (rev (loop (t
, [])))
127 print
: string -> unit
,
130 (*val _
= outputTree (t
, out
)*)
131 fun newline () = print
"\n"
133 fun outputCompact (t
, {at
, printAt
= _
}) =
135 fun loop (T
{tree
, ...}) =
138 |
String s
=> print s
139 | Sequence ts
=> app loop ts
140 | Align
{rows
, ...} =>
144 ; app (fn t
=> (print
" "; loop t
)) ts
))
145 |
Indent (t
, _
) => loop t
146 | Compact t
=> loop t
147 val at
= at
+ length t
149 ; {at
= at
, printAt
= at
}
152 fun loop (t
as T
{length
, tree
}, state
as {at
, printAt
}) =
156 then () (* can
't back up
*)
157 else print (blanks (printAt
- at
))
158 in (*Out
.print (concat
["at ", Int.toString at
,
159 * " printAt ", Int.toString printAt
,
162 (*outputTree (t
, Out
.error
)*)
168 ; let val at
= printAt
+ length
169 in {at
= at
, printAt
= at
}
171 | Sequence ts
=> fold (ts
, state
, loop
)
172 | Align
{force
, rows
} =>
173 if not force
andalso printAt
+ length
<= lineWidth
175 ; outputCompact (t
, state
))
180 (ts
, loop (t
, state
), fn (t
, _
) =>
182 ; loop (t
, {at
= 0, printAt
= printAt
}))))
183 |
Indent (t
, n
) => loop (t
, {at
= at
, printAt
= printAt
+ n
})
184 | Compact t
=> (prePrint ()
185 ; outputCompact (t
, state
))
188 in ignore (loop (tree
, {at
= 0, printAt
= 0}))
191 fun outputWidth (t
, width
, out
) =
194 print
= Out
.outputc out
}
197 val defaultWidth
: int ref
= ref
80
199 fun setDefaultWidth w
= defaultWidth
:= w
200 fun output (t
, out
) = outputWidth (t
, !defaultWidth
, out
)
202 fn (t
, p
) => print
{tree
= t
, lineWidth
= !defaultWidth
, print
= p
}
205 fun outputl (t
, out
) = (output (t
, out
); Out
.newline out
)
207 fun makeOutput
layoutX (x
, out
) = output (layoutX x
, out
)
211 fun separate (ts
, s
) =
214 | t
:: ts
=> t
:: (let val s
= str s
216 |
loop (t
:: ts
) = s
:: t
:: (loop ts
)
220 fun separateLeft (ts
, s
) =
224 | t
:: ts
=> t
:: (map (fn t
=> seq
[str s
, t
]) ts
)
226 fun separateRight (ts
, s
) =
227 rev (let val ts
= rev ts
231 | t
:: ts
=> t
:: (map (fn t
=> seq
[t
, str s
]) ts
)
234 fun alignPrefix (ts
, prefix
) =
238 mayAlign (t
::(map (fn t
=> indent (seq
[str prefix
, t
], ~
(String.size prefix
))) ts
))
245 | t1
::t2
::ts
=> mayAlign
[t1
, t2
] :: fillAux ts
251 | _
=> fill (fillAux ts
)
255 fun sequence (start
, finish
, sep
) ts
=
256 seq
[str start
, mayAlign (separateRight (ts
, sep
)), str finish
]
258 val list
= sequence ("[", "]", ",")
259 val schemeList
= sequence ("(", ")", " ")
260 val tuple
= sequence ("(", ")", ",")
262 sequence ("{", "}", ",")
263 (map (fn (f
, t
) => seq
[str (f ^
" = "), t
]) fts
)
265 sequence ("#[", "]", ",")
266 (Pervasive
.Vector.foldr (op ::) [] v
)
268 sequence ("#![", "]", ",")
269 (Pervasive
.Array
.foldr (op ::) [] v
)
272 fun namedRecord (name
, fields
) = seq
[str name
, str
" ", record fields
]
274 fun paren t
= seq
[str
"(", t
, str
")"]
276 fun tuple2 (l1
, l2
) (x1
, x2
) = tuple
[l1 x1
, l2 x2
]
277 fun tuple3 (l1
, l2
, l3
) (x1
, x2
, x3
) = tuple
[l1 x1
, l2 x2
, l3 x3
]
278 fun tuple4 (l1
, l2
, l3
, l4
) (x1
, x2
, x3
, x4
) = tuple
[l1 x1
, l2 x2
, l3 x3
, l4 x4
]
279 fun tuple5 (l1
, l2
, l3
, l4
, l5
) (x1
, x2
, x3
, x4
, x5
) =
280 tuple
[l1 x1
, l2 x2
, l3 x3
, l4 x4
, l5 x5
]