src/Pure/ML/ml_pretty.ML
author wenzelm
Thu Mar 17 16:56:44 2016 +0100 (2016-03-17)
changeset 62662 291cc01f56f5
parent 62661 c23ff2f45a18
child 62663 bea354f6ff21
permissions -rw-r--r--
@{make_string} is available during Pure bootstrap;
     1 (*  Title:      Pure/ML/ml_pretty.ML
     2     Author:     Makarius
     3 
     4 Minimal support for raw ML pretty printing, notably for toplevel pp.
     5 *)
     6 
     7 signature ML_PRETTY =
     8 sig
     9   datatype pretty =
    10     Block of (string * string) * bool * FixedInt.int * pretty list |
    11     String of string * FixedInt.int |
    12     Break of bool * FixedInt.int * FixedInt.int
    13   val block: pretty list -> pretty
    14   val str: string -> pretty
    15   val brk: FixedInt.int -> pretty
    16   val pair: ('a * int -> pretty) -> ('b * int -> pretty) -> ('a * 'b) * int -> pretty
    17   val enum: string -> string -> string -> ('a * int -> pretty) -> 'a list * int -> pretty
    18   val to_polyml: pretty -> PolyML.pretty
    19   val from_polyml: PolyML.pretty -> pretty
    20   val get_print_depth: unit -> int
    21   val print_depth: int -> unit
    22   val format_polyml: int -> PolyML.pretty -> string
    23   val format: int -> pretty -> string
    24   val make_string_fn: string -> string
    25 end;
    26 
    27 structure ML_Pretty: ML_PRETTY =
    28 struct
    29 
    30 (* datatype pretty *)
    31 
    32 datatype pretty =
    33   Block of (string * string) * bool * FixedInt.int * pretty list |
    34   String of string * FixedInt.int |
    35   Break of bool * FixedInt.int * FixedInt.int;
    36 
    37 fun block prts = Block (("", ""), false, 2, prts);
    38 fun str s = String (s, FixedInt.fromInt (size s));
    39 fun brk width = Break (false, width, 0);
    40 
    41 fun pair pretty1 pretty2 ((x, y), depth: FixedInt.int) =
    42   block [str "(", pretty1 (x, depth), str ",", brk 1, pretty2 (y, depth - 1), str ")"];
    43 
    44 fun enum sep lpar rpar pretty (args, depth: FixedInt.int) =
    45   let
    46     fun elems _ [] = []
    47       | elems 0 _ = [str "..."]
    48       | elems d [x] = [pretty (x, d)]
    49       | elems d (x :: xs) = pretty (x, d) :: str sep :: brk 1 :: elems (d - 1) xs;
    50   in block (str lpar :: (elems (FixedInt.max (depth, 0)) args @ [str rpar])) end;
    51 
    52 
    53 (* convert *)
    54 
    55 fun to_polyml (Break (false, width, offset)) = PolyML.PrettyBreak (width, offset)
    56   | to_polyml (Break (true, _, _)) =
    57       PolyML.PrettyBlock (0, false, [PolyML.ContextProperty ("fbrk", "")],
    58         [PolyML.PrettyString " "])
    59   | to_polyml (Block ((bg, en), consistent, ind, prts)) =
    60       let val context =
    61         (if bg = "" then [] else [PolyML.ContextProperty ("begin", bg)]) @
    62         (if en = "" then [] else [PolyML.ContextProperty ("end", en)])
    63       in PolyML.PrettyBlock (ind, consistent, context, map to_polyml prts) end
    64   | to_polyml (String (s, len)) =
    65       if len = FixedInt.fromInt (size s) then PolyML.PrettyString s
    66       else
    67         PolyML.PrettyBlock
    68           (0, false,
    69             [PolyML.ContextProperty ("length", FixedInt.toString len)], [PolyML.PrettyString s]);
    70 
    71 val from_polyml =
    72   let
    73     fun convert _ (PolyML.PrettyBreak (width, offset)) = Break (false, width, offset)
    74       | convert _ (PolyML.PrettyBlock (_, _,
    75             [PolyML.ContextProperty ("fbrk", _)], [PolyML.PrettyString " "])) =
    76           Break (true, 1, 0)
    77       | convert len (PolyML.PrettyBlock (ind, consistent, context, prts)) =
    78           let
    79             fun property name default =
    80               (case List.find (fn PolyML.ContextProperty (a, _) => name = a | _ => false) context of
    81                 SOME (PolyML.ContextProperty (_, b)) => b
    82               | _ => default);
    83             val bg = property "begin" "";
    84             val en = property "end" "";
    85             val len' = property "length" len;
    86           in Block ((bg, en), consistent, ind, map (convert len') prts) end
    87       | convert len (PolyML.PrettyString s) =
    88           String (s, FixedInt.fromInt (case Int.fromString len of SOME i => i | NONE => size s))
    89   in convert "" end;
    90 
    91 
    92 (* default print depth *)
    93 
    94 local
    95   val depth = Unsynchronized.ref 0;
    96 in
    97   fun get_print_depth () = ! depth;
    98   fun print_depth n = (depth := n; PolyML.print_depth n);
    99   val _ = print_depth 10;
   100 end;
   101 
   102 
   103 (* format *)
   104 
   105 fun format_polyml margin prt =
   106   let
   107     val result = Unsynchronized.ref [];
   108     val () = PolyML.prettyPrint (fn s => result := s :: ! result, margin) prt
   109   in String.concat (List.rev (! result)) end;
   110 
   111 fun format margin = format_polyml margin o to_polyml;
   112 
   113 
   114 (* make string *)
   115 
   116 local
   117   fun pretty_string_of s =
   118     "(fn x => Pretty.string_of (Pretty.from_ML (ML_Pretty.from_polyml (" ^ s ^ "))))";
   119   fun pretty_value depth = "PolyML.prettyRepresentation (x, FixedInt.fromInt (" ^ depth ^ "))";
   120 in
   121 
   122 fun make_string_fn local_env =
   123   if local_env <> "" then
   124     pretty_string_of (pretty_value (local_env ^ ".ML_print_depth ()"))
   125   else if List.exists (fn (a, _) => a = "Pretty") (#allStruct ML_Name_Space.global ()) then
   126     pretty_string_of (pretty_value "ML_Pretty.get_print_depth ()")
   127   else "(fn x => ML_Pretty.format_polyml 78 (" ^ pretty_value "ML_Pretty.get_print_depth ()" ^ "))";
   128 
   129 end;
   130 
   131 end;