layout.sml 9.59 KB
Newer Older
mb0's avatar
mb0 committed
1 2
(* Copyright (C) 2009 Matthew Fluet.
 * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
mb0's avatar
mb0 committed
3 4
 *    Jagannathan, and Stephen Weeks.
 *
mb0's avatar
mb0 committed
5 6
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
mb0's avatar
mb0 committed
7 8 9 10 11 12 13
 *)
structure Layout :> LAYOUT =
struct

(*    structure Out = Outstream0   *)

    val detailed = ref false
mb0's avatar
mb0 committed
14

mb0's avatar
mb0 committed
15 16
    fun switch {detailed = d,normal = n} x =
        if !detailed then d x else n x
mb0's avatar
mb0 committed
17

mb0's avatar
mb0 committed
18 19 20 21 22 23 24 25 26 27 28 29
    datatype t = T of {length: int,
                       tree: tree}
    and tree =
        Empty
      | String of string
      | Sequence of t list
      | Align of {force: bool, rows: t list}
      | Indent of t * int

    type layout = t

    fun length (T {length, ...}) = length
mb0's avatar
mb0 committed
30

mb0's avatar
mb0 committed
31
    val empty = T {length = 0, tree = Empty}
mb0's avatar
mb0 committed
32

mb0's avatar
mb0 committed
33 34
    fun isEmpty (T {length = 0, ...}) = true
      | isEmpty _ = false
mb0's avatar
mb0 committed
35

mb0's avatar
mb0 committed
36 37 38 39
    fun str s =
        case s of
            "" => empty
          | _ => T {length = String.size s, tree = String s}
mb0's avatar
mb0 committed
40

mb0's avatar
mb0 committed
41
    fun fold (l, b, f) = foldl f b l
mb0's avatar
mb0 committed
42

mb0's avatar
mb0 committed
43 44 45 46 47 48 49 50 51 52 53
    fun seq ts =
        let val len = fold (ts, 0, fn (t,n) => n + length t)
        in case len of
            0 => empty
          | _ => T {length = len, tree = Sequence ts}
        end

    (* XXX mayalign should do 'partial spill', so that a long list of
       short elements displays as
       [1, 2, 3
        4, 5, 6]
mb0's avatar
mb0 committed
54

mb0's avatar
mb0 committed
55
       instead of
mb0's avatar
mb0 committed
56

mb0's avatar
mb0 committed
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
       [1,
        2,
        3,
        4,
        5,
        6] *)

    local
        fun make force ts =
            let
                fun loop ts =
                    case ts of
                        [] => (ts, 0)
                      | t :: ts =>
                            let val (ts, n) = loop ts
                            in case length t of
                                0 => (ts, n)
                              | n' => (t :: ts, n + n' + 1)
                            end
                val (ts, len) = loop ts
            in case len of
                0 => empty
              | _ => T {length = len - 1, tree = Align {force = force, rows = ts}}
            end
    in
        val align = make true
        val mayAlign = make false
    end

    fun indent (t, n) = T {length = length t, tree = Indent (t, n)}
mb0's avatar
mb0 committed
87

mb0's avatar
mb0 committed
88
    val tabSize: int = 8
mb0's avatar
mb0 committed
89

mb0's avatar
mb0 committed
90 91 92 93 94
    fun K x _ = x

    fun blanks (n: int): string =
        concat [CharVector.tabulate (n div tabSize, K #"\t"),
                CharVector.tabulate (n mod tabSize, K #" ")]
mb0's avatar
mb0 committed
95

mb0's avatar
mb0 committed
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
(*
    fun outputTree (t, out) =
        let val print = Out.outputc out
            fun loop (T {tree, length}) =
                (print "(length "
                 ; print (Int.toString length)
                 ; print ")"
                 ; (case tree of
                        Empty => print "Empty"
                      | String s => (print "(String "; print s; print ")")
                      | Sequence ts => loops ("Sequence", ts)
                      | Align {force, rows} => loops ("Align", rows)
                      | Indent (t, n) => (print "(Indent "
                                          ; print (Int.toString n)
                                          ; print " "
                                          ; loop t
                                          ; print ")")))
            and loops (s, ts) = (print "("
                                 ; print s
                                 ; app (fn t => (print " " ; loop t)) ts
                                 ; print ")")
        in loop t
        end
mb0's avatar
mb0 committed
119
*)
mb0's avatar
mb0 committed
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140

(* doesn't include newlines. new version below - tom *)

(*
    fun tostring t =
        let
            fun loop (T {tree, ...}, accum) =
                case tree of
                    Empty => accum
                  | String s => s :: accum
                  | Sequence ts => fold (ts, accum, loop)
                  | Align {rows, ...} =>
                        (case rows of
                             [] => accum
                           | t :: ts =>
                                 fold (ts, loop (t, accum), fn (t, ac) =>
                                       loop (t, " " :: ac)))
                  | Indent (t, _) => loop (t, accum)
        in
            String.concat (rev (loop (t, [])))
        end
mb0's avatar
mb0 committed
141
*)
mb0's avatar
mb0 committed
142 143 144 145 146 147
    fun layout_print {tree: t,
               print: string -> unit,
               lineWidth: int} =
        let
            (*val _ = outputTree (t, out)*)
            fun newline () = print "\n"
mb0's avatar
mb0 committed
148

mb0's avatar
mb0 committed
149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
            fun outputCompact (t, {at, printAt}) =
                let
                    fun loop (T {tree, ...}) =
                        case tree of
                            Empty => ()
                          | String s => print s
                          | Sequence ts => app loop ts
                          | Indent (t, _) => loop t
                          | Align {rows, ...} =>
                                case rows of
                                    [] => ()
                                  | t :: ts => (loop t
                                                ; app (fn t => (print " "; loop t)) ts)
                    val at = at + length t
                in loop t
                    ; {at = at, printAt = at}
                end
mb0's avatar
mb0 committed
166

mb0's avatar
mb0 committed
167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229
            fun loop (t as T {length, tree}, state as {at, printAt}) =
                let
                    fun prePrint () =
                        if at >= printAt
                        then () (* can't back up *)
                        else print (blanks (printAt - at))
                in (*Out.print (concat ["at ", Int.toString at,
                * "  printAt ", Int.toString printAt,
                * "\n"]);
                *)
                    (*outputTree (t, Out.error)*)
                    case tree of
                        Empty => state
                      | Indent (t, n) => loop (t, {at = at, printAt = printAt + n})
                      | Sequence ts => fold (ts, state, loop)
                      | String s =>
                            (prePrint ()
                             ; print s
                             ; let val at = printAt + length
                               in {at = at, printAt = at}
                               end)
                      | Align {force, rows} =>
                            if not force andalso printAt + length <= lineWidth
                            then (prePrint ()
                                  ; outputCompact (t, state))
                            else (case rows of
                                      [] => state
                                    | t :: ts =>
                                          fold
                                          (ts, loop (t, state), fn (t, _) =>
                                           (newline ()
                                            ; loop (t, {at = 0, printAt = printAt}))))
                end
        in ignore (loop (tree, {at = 0, printAt = 0}))
        end

    val defaultWidth: int = 80

    fun tostringex wid l =
        let
            val acc = ref nil : string list ref

            fun pr s = acc := s :: !acc
        in
            layout_print {tree = l, lineWidth = wid, print = pr};

            String.concat(rev (!acc))
        end

    val tostring = tostringex defaultWidth

(*
    fun outputWidth (t, width, out) =
    layout_print {tree = t,
               lineWidth = width,
               print = Out.outputc out}
*)
(*        fun output (t, out) = outputWidth (t, defaultWidth, out) *)
        val print =
            fn (t, p) => layout_print {tree = t, lineWidth = defaultWidth, print = p}

(*
    fun outputl (t, out) = (output (t, out); Out.newline out)
mb0's avatar
mb0 committed
230
*)
mb0's avatar
mb0 committed
231 232

(*     fun makeOutput layoutX (x, out) = output (layoutX x, out)
mb0's avatar
mb0 committed
233
 *)
mb0's avatar
mb0 committed
234
    fun ignore _ = empty
mb0's avatar
mb0 committed
235

mb0's avatar
mb0 committed
236 237 238 239 240 241 242 243
    fun separate (ts, s) =
        case ts of
            [] => []
          | t :: ts => t :: (let val s = str s
                                 fun loop [] = []
                                   | loop (t :: ts) = s :: t:: (loop ts)
                             in loop ts
                             end)
mb0's avatar
mb0 committed
244

mb0's avatar
mb0 committed
245 246 247 248 249
    fun separateLeft (ts, s) =
        case ts of
            [] => []
          | [t] => ts
          | t :: ts => t :: (map (fn t => seq [str s, t]) ts)
mb0's avatar
mb0 committed
250

mb0's avatar
mb0 committed
251 252 253 254 255 256 257
    fun separateRight (ts, s) =
        rev (let val ts = rev ts
             in case ts of
                 [] => []
               | [t] => ts
               | t :: ts => t :: (map (fn t => seq [t, str s]) ts)
             end)
mb0's avatar
mb0 committed
258

mb0's avatar
mb0 committed
259 260 261 262 263 264
    fun alignPrefix (ts, prefix) =
        case ts of
            [] => empty
          | t :: ts =>
                mayAlign [t, indent (mayAlign (map (fn t => seq [str prefix, t]) ts),
                                     ~ (String.size prefix))]
mb0's avatar
mb0 committed
265

mb0's avatar
mb0 committed
266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288
    local
        fun sequence (start, finish, sep) ts =
            seq [str start, mayAlign (separateRight (ts, sep)), str finish]
    in
        val list = sequence ("[", "]", ",")
        fun listex start finish sep = sequence (start, finish, sep)
        val schemeList = sequence ("(", ")", " ")
        val tuple = sequence ("(", ")", ",")
        fun record fts =
            sequence ("{", "}", ",")
            (map (fn (f, t) => seq [str (f ^ " = "), t]) fts)

        fun recordex sep fts =
            sequence ("{", "}", ",")
            (map (fn (f, t) => seq [str (f ^ " " ^ sep ^ " "), t]) fts)

    end

    fun vector v = tuple (Vector.foldr (op ::) [] v)

    fun array x = list (Array.foldr (op ::) [] x)

    fun namedRecord (name, fields) = seq [str name, str " ", record fields]
mb0's avatar
mb0 committed
289

mb0's avatar
mb0 committed
290
    fun paren t = seq [str "(", t, str ")"]
mb0's avatar
mb0 committed
291

mb0's avatar
mb0 committed
292 293 294 295 296 297 298 299 300
    fun tuple2 (l1, l2) (x1, x2) = tuple [l1 x1, l2 x2]
    fun tuple3 (l1, l2, l3) (x1, x2, x3) = tuple [l1 x1, l2 x2, l3 x3]
    fun tuple4 (l1, l2, l3, l4) (x1, x2, x3, x4) = tuple [l1 x1, l2 x2, l3 x3, l4 x4]
    fun tuple5 (l1, l2, l3, l4, l5) (x1, x2, x3, x4, x5) =
        tuple [l1 x1, l2 x2, l3 x3, l4 x4, l5 x5]

    val indent = fn x => fn y => indent(y, x)

end