ADDED src/natools-s_expressions-printers-pretty.adb Index: src/natools-s_expressions-printers-pretty.adb ================================================================== --- src/natools-s_expressions-printers-pretty.adb +++ src/natools-s_expressions-printers-pretty.adb @@ -0,0 +1,1061 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013-2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +package body Natools.S_Expressions.Printers.Pretty is + + function Fit_In_Line + (Output : in Printer; + Width : in Screen_Offset) + return Boolean; + -- Return whether Width can fit in the current line of Output + + function Indent_Width (Output : in Printer) return Screen_Offset; + -- Return current indentation width on screen + + function Is_Extended_Token (Data : in Atom) return Boolean; + -- Check whether Atom can be parsed by Natools.S_Expressions.Parsers + -- when encoded as a token. + + function Is_Standard_Token (Data : in Atom) return Boolean; + -- Check whether Atom can be encoded as a token according to Standard + + function Is_Newline + (Data : in Atom; + Position : in Offset; + Encoding : in Newline_Encoding) + return Boolean; + -- Check whether Data contains a newline at Position + + procedure Newline (Output : in out Printer); + -- Output a newline and indentation + + procedure Quoted_Lengths + (Data : in Atom; + Encoding : in Character_Encoding; + Width : in Screen_Offset; + Newline : in Newline_Encoding; + Single_Line : in Boolean; + Size : out Count; + Cursor : in out Screen_Offset); + -- Dry run of quoted-string encoding of Data, to measure the output + -- length and the final position of the screen cursor. + + function Multi_Line_Quoted_Size + (Output : in Printer; + Data : in Atom) + return Count; + -- Return how much octets a multi-line encoding of Data in Output + -- would take. + + function Single_Line_Quoted_Size + (Data : in Atom; + Encoding : in Character_Encoding) + return Count; + pragma Unreferenced (Single_Line_Quoted_Size); + -- Return how much octets a single line encoding of Data would take + + function Single_Line_Quoted_Width + (Data : in Atom; + Encoding : in Character_Encoding) + return Screen_Offset; + -- Return how much screen space a single line encoding of Data takes + + function UTF_Character_Size (Data : in Atom; Position : in Offset) + return Count; + -- Return how much octets spans the UTF-8 character at Position + -- in Data, or 0 when it's an invalid UTF-8 sequence. + + procedure Write_Base64 (Output : in out Printer; Data : in Atom); + -- Output base-64 encoding of Data + + procedure Write_Hex (Output : in out Printer; Data : in Atom); + -- Output hexadecimal encoding of Data + + procedure Write_Quoted + (Output : in out Printer; + Data : in Atom; + Single_Line : in Boolean); + -- Output quoted-string encoding of Data + + procedure Write_Verbatim (Output : in out Printer; Data : in Atom); + -- Output verbatim encoding of Data + + + + ------------------------ + -- Helper Subprograms -- + ------------------------ + + function Fit_In_Line + (Output : in Printer; + Width : in Screen_Offset) + return Boolean is + begin + return Output.Param.Width = 0 + or Output.Param.Width >= Output.Cursor + Width; + end Fit_In_Line; + + + function Indent_Width (Output : in Printer) return Screen_Offset is + begin + if Output.Indent_Level > 0 and Output.Param.Indentation > 0 then + case Output.Param.Indent is + when Spaces | Tabs_And_Spaces => + return Output.Param.Indentation * Output.Indent_Level; + when Tabs => + return Output.Param.Indentation * Output.Indent_Level + * Output.Param.Tab_Stop; + end case; + else + return 0; + end if; + end Indent_Width; + + + function Is_Extended_Token (Data : in Atom) return Boolean is + begin + for I in Data'Range loop + case Data (I) is + when 0 | Encodings.Space | Encodings.HT | Encodings.VT + | Encodings.LF | Encodings.CR | Encodings.FF + | Encodings.List_Begin | Encodings.List_End => + return False; + when others => null; + end case; + end loop; + + return Data'Length > 0; + end Is_Extended_Token; + + + function Is_Standard_Token (Data : in Atom) return Boolean is + begin + if Data'Length = 0 + or else Data (Data'First) in Encodings.Digit_0 .. Encodings.Digit_9 + then + return False; + end if; + + for I in Data'Range loop + case Data (I) is + when Encodings.Upper_A .. Encodings.Upper_Z + | Encodings.Lower_A .. Encodings.Lower_Z + | Encodings.Digit_0 .. Encodings.Digit_9 + | Character'Pos ('-') + | Character'Pos ('.') + | Character'Pos ('/') + | Character'Pos ('_') + | Character'Pos (':') + | Character'Pos ('*') + | Character'Pos ('+') + | Character'Pos ('=') => + null; + when others => return False; + end case; + end loop; + + return True; + end Is_Standard_Token; + + + function UTF_Character_Size (Data : in Atom; Position : in Offset) + return Count is + begin + case Data (Position) is + when 2#0000_0000# .. 2#0111_1111# => + return 1; + when 2#1000_0000# .. 2#1011_1111# => + return 0; + when 2#1100_0000# .. 2#1101_1111# => + if Position + 1 in Data'Range + and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111# + then + return 2; + else + return 0; + end if; + when 2#1110_0000# .. 2#1110_1111# => + if Position + 2 in Data'Range + and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 2) in 2#1000_0000# .. 2#1011_1111# + then + return 3; + else + return 0; + end if; + when 2#1111_0000# .. 2#1111_0111# => + if Position + 3 in Data'Range + and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 2) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 3) in 2#1000_0000# .. 2#1011_1111# + then + return 4; + else + return 0; + end if; + when 2#1111_1000# .. 2#1111_1011# => + if Position + 4 in Data'Range + and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 2) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 3) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 4) in 2#1000_0000# .. 2#1011_1111# + then + return 5; + else + return 0; + end if; + when 2#1111_1100# .. 2#1111_1101# => + if Position + 5 in Data'Range + and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 2) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 3) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 4) in 2#1000_0000# .. 2#1011_1111# + and then Data (Position + 5) in 2#1000_0000# .. 2#1011_1111# + then + return 6; + else + return 0; + end if; + when 2#1111_1110# .. 2#1111_1111# => + return 0; + end case; + end UTF_Character_Size; + + + function Is_Newline + (Data : in Atom; + Position : in Offset; + Encoding : in Newline_Encoding) + return Boolean is + begin + case Encoding is + when CR => + return Data (Position) = Encodings.CR; + when LF => + return Data (Position) = Encodings.LF; + when CR_LF => + return Position + 1 in Data'Range + and then Data (Position) = Encodings.CR + and then Data (Position + 1) = Encodings.LF; + when LF_CR => + return Position + 1 in Data'Range + and then Data (Position) = Encodings.LF + and then Data (Position + 1) = Encodings.CR; + end case; + end Is_Newline; + + + procedure Newline (Output : in out Printer) is + Data : Atom (0 .. 1); + Length : Count; + begin + case Output.Param.Newline is + when CR => + Data (0) := Encodings.CR; + Length := 1; + when LF => + Data (0) := Encodings.LF; + Length := 1; + when CR_LF => + Data (0) := Encodings.CR; + Data (1) := Encodings.LF; + Length := 2; + when LF_CR => + Data (0) := Encodings.LF; + Data (1) := Encodings.CR; + Length := 2; + end case; + Output.Stream.Write (Data (0 .. Length - 1)); + + if Output.Indent_Level > 0 and Output.Param.Indentation > 0 then + case Output.Param.Indent is + when Spaces => + Output.Cursor := Output.Param.Indentation * Output.Indent_Level + + 1; + Output.Stream.Write ((1 .. Count (Output.Cursor) - 1 + => Encodings.Space)); + when Tabs => + Output.Cursor := Output.Param.Indentation * Output.Indent_Level; + Output.Stream.Write ((1 .. Count (Output.Cursor) + => Encodings.HT)); + Output.Cursor := Output.Cursor * Output.Param.Tab_Stop; + when Tabs_And_Spaces => + Output.Cursor := Output.Param.Indentation * Output.Indent_Level + + 1; + declare + Tab_Count : constant Count + := (Count (Output.Cursor) - 1) + / Count (Output.Param.Tab_Stop); + Space_Count : constant Count + := (Count (Output.Cursor) - 1) + mod Count (Output.Param.Tab_Stop); + begin + Output.Stream.Write ((1 .. Tab_Count => Encodings.HT)); + Output.Stream.Write ((1 .. Space_Count => Encodings.Space)); + end; + end case; + else + Output.Cursor := 1; + end if; + end Newline; + + + procedure Quoted_Lengths + (Data : in Atom; + Encoding : in Character_Encoding; + Width : in Screen_Offset; + Newline : in Newline_Encoding; + Single_Line : in Boolean; + Size : out Count; + Cursor : in out Screen_Offset) + is + C : Count; + I : Offset := Data'First; + Last_Non_NL : Offset := Data'Last; + begin + while Last_Non_NL in Data'Range + and then (Data (Last_Non_NL) = Encodings.CR + or Data (Last_Non_NL) = Encodings.LF) + loop + Last_Non_NL := Last_Non_NL - 1; + end loop; + + Size := 2; + Cursor := Cursor + 1; + while I in Data'Range loop + case Data (I) is + when 8 | 9 | 11 | 12 + | Encodings.Quoted_Atom_End | Encodings.Escape => + Size := Size + 2; + Cursor := Cursor + 2; + when 10 | 13 => + if Single_Line + or else I > Last_Non_NL + or else not Is_Newline (Data, I, Newline) + then + Size := Size + 2; + Cursor := Cursor + 2; + else + Size := Size + 1; + Cursor := 1; + end if; + when 0 .. 7 | 14 .. 31 => + Size := Size + 4; + Cursor := Cursor + 4; + when 16#80# .. 16#FF# => + case Encoding is + when ASCII => + Size := Size + 4; + Cursor := Cursor + 4; + when Latin => + if Data (I) in 16#80# .. 16#9F# then + Size := Size + 4; + Cursor := Cursor + 4; + else + Size := Size + 1; + Cursor := Cursor + 1; + end if; + when UTF_8 => + C := UTF_Character_Size (Data, I); + if C = 0 then + Size := Size + 4; + Cursor := Cursor + 4; + else + Size := Size + C; + Cursor := Cursor + 1; + I := I + C - 1; + end if; + end case; + when others => + Size := Size + 1; + Cursor := Cursor + 1; + end case; + + if not Single_Line + and then Width > 0 + and then Cursor >= Width + then + case Newline is + when CR | LF => + Size := Size + 2; + when CR_LF | LF_CR => + Size := Size + 3; + end case; + Cursor := 1; + end if; + + I := I + 1; + end loop; + + Cursor := Cursor + 1; + end Quoted_Lengths; + + + function Multi_Line_Quoted_Size + (Output : in Printer; + Data : in Atom) + return Count + is + Discarded_Cursor : Screen_Offset := Output.Cursor; + Result : Count; + begin + Quoted_Lengths + (Data, + Output.Param.Char_Encoding, + Output.Param.Width, + Output.Param.Newline, + False, + Result, + Discarded_Cursor); + return Result; + end Multi_Line_Quoted_Size; + + + function Single_Line_Quoted_Size + (Data : in Atom; + Encoding : in Character_Encoding) + return Count + is + Discarded : Screen_Offset := 0; + Result : Count; + begin + Quoted_Lengths + (Data, Encoding, + 0, CR, True, + Result, Discarded); + return Result; + end Single_Line_Quoted_Size; + + + function Single_Line_Quoted_Width + (Data : in Atom; + Encoding : in Character_Encoding) + return Screen_Offset + is + Result : Screen_Offset := 0; + Discarded : Count; + begin + Quoted_Lengths + (Data, Encoding, + 0, CR, True, + Discarded, Result); + return Result; + end Single_Line_Quoted_Width; + + + procedure Write_Base64 (Output : in out Printer; Data : in Atom) is + Available : Screen_Offset; + I : Offset := Data'First; + Chunk_Size : Count; + begin + if Output.Param.Width = 0 then + Output.Stream.Write ((0 => Encodings.Base64_Atom_Begin)); + Output.Stream.Write (Encodings.Encode_Base64 (Data)); + Output.Stream.Write ((0 => Encodings.Base64_Atom_End)); + else + Output.Stream.Write ((0 => Encodings.Base64_Atom_Begin)); + Output.Cursor := Output.Cursor + 1; + + loop + Available := Output.Param.Width - Output.Cursor; + Chunk_Size := Count (Available) / 4 * 3; + + if Available mod 4 /= 0 then + Output.Stream.Write ((0 => Encodings.Space)); + Output.Cursor := Output.Cursor + 1; + end if; + + if I + Chunk_Size in Data'Range then + Output.Stream.Write (Encodings.Encode_Base64 + (Data (I .. I + Chunk_Size - 1))); + Newline (Output); + I := I + Chunk_Size; + else + Output.Stream.Write (Encodings.Encode_Base64 + (Data (I .. Data'Last))); + Output.Stream.Write ((0 => Encodings.Base64_Atom_End)); + Output.Cursor := Output.Cursor + + Screen_Offset (Data'Last - I + 2) / 3 * 4 + 1; + exit; + end if; + end loop; + end if; + end Write_Base64; + + + procedure Write_Hex (Output : in out Printer; Data : in Atom) is + Available : Screen_Offset; + I : Offset := Data'First; + Chunk_Size : Count; + begin + if Output.Param.Width = 0 then + Output.Stream.Write ((0 => Encodings.Hex_Atom_Begin)); + Output.Stream.Write (Encodings.Encode_Hex (Data, + Output.Param.Hex_Casing)); + Output.Stream.Write ((0 => Encodings.Hex_Atom_End)); + else + Output.Stream.Write ((0 => Encodings.Hex_Atom_Begin)); + Output.Cursor := Output.Cursor + 1; + + loop + Available := Output.Param.Width - Output.Cursor; + Chunk_Size := Count (Available) / 2; + + if Available mod 2 = 1 then + Output.Stream.Write ((0 => Encodings.Space)); + Output.Cursor := Output.Cursor + 1; + end if; + + if I + Chunk_Size in Data'Range then + Output.Stream.Write (Encodings.Encode_Hex + (Data (I .. I + Chunk_Size - 1), + Output.Param.Hex_Casing)); + Newline (Output); + I := I + Chunk_Size; + else + Output.Stream.Write (Encodings.Encode_Hex + (Data (I .. Data'Last), + Output.Param.Hex_Casing)); + Output.Stream.Write ((0 => Encodings.Hex_Atom_End)); + Output.Cursor := Output.Cursor + + Screen_Offset (Data'Last - I + 1) * 2 + 1; + exit; + end if; + end loop; + end if; + end Write_Hex; + + + procedure Write_Quoted + (Output : in out Printer; + Data : in Atom; + Single_Line : in Boolean) + is + procedure Escape + (Value : in Octet; + Result : out Atom; + Pos : in out Offset); + + Size : Count; + Last_Non_NL : Offset := Data'Last; + + procedure Escape + (Value : in Octet; + Result : out Atom; + Pos : in out Offset) is + begin + Result (Pos) := Encodings.Escape; + + case Output.Param.Quoted_Escape is + when Octal_Escape => + Result (Pos + 1) := Encodings.Digit_0 + (Value / 2**6); + Result (Pos + 2) := Encodings.Digit_0 + (Value / 2**3) mod 2**3; + Result (Pos + 3) := Encodings.Digit_0 + (Value mod 2**3); + when Hex_Escape => + Result (Pos + 1) := Character'Pos ('x'); + Encodings.Encode_Hex + (Value, + Output.Param.Hex_Casing, + Result (Pos + 2), + Result (Pos + 3)); + end case; + Pos := Pos + 4; + end Escape; + begin + declare + Discarded_Cursor : Screen_Offset := Output.Cursor; + begin + Quoted_Lengths + (Data, + Output.Param.Char_Encoding, + Output.Param.Width, + Output.Param.Newline, + Single_Line, + Size, + Discarded_Cursor); + end; + + while Last_Non_NL in Data'Range + and then (Data (Last_Non_NL) = Encodings.CR + or Data (Last_Non_NL) = Encodings.LF) + loop + Last_Non_NL := Last_Non_NL - 1; + end loop; + + declare + Result : Atom (0 .. Size - 1); + I : Offset := Data'First; + O : Offset := Result'First + 1; + C : Count; + begin + Result (0) := Encodings.Quoted_Atom_Begin; + Output.Cursor := Output.Cursor + 1; + + while I in Data'Range loop + case Data (I) is + when 8 => + Result (O) := Encodings.Escape; + Result (O + 1) := Character'Pos ('b'); + O := O + 2; + Output.Cursor := Output.Cursor + 2; + when 9 => + Result (O) := Encodings.Escape; + Result (O + 1) := Character'Pos ('t'); + O := O + 2; + Output.Cursor := Output.Cursor + 2; + when 10 => + if Single_Line + or else I > Last_Non_NL + or else not Is_Newline (Data, I, Output.Param.Newline) + then + Result (O) := Encodings.Escape; + Result (O + 1) := Character'Pos ('n'); + O := O + 2; + Output.Cursor := Output.Cursor + 2; + else + Result (O) := Data (I); + O := O + 1; + Output.Cursor := 1; + end if; + when 11 => + Result (O) := Encodings.Escape; + Result (O + 1) := Character'Pos ('v'); + O := O + 2; + Output.Cursor := Output.Cursor + 2; + when 12 => + Result (O) := Encodings.Escape; + Result (O + 1) := Character'Pos ('f'); + O := O + 2; + Output.Cursor := Output.Cursor + 2; + when 13 => + if Single_Line + or else I > Last_Non_NL + or else not Is_Newline (Data, I, Output.Param.Newline) + then + Result (O) := Encodings.Escape; + Result (O + 1) := Character'Pos ('r'); + O := O + 2; + Output.Cursor := Output.Cursor + 2; + else + Result (O) := Data (I); + O := O + 1; + Output.Cursor := 1; + end if; + when Encodings.Quoted_Atom_End | Encodings.Escape => + Result (O) := Encodings.Escape; + Result (O + 1) := Data (I); + O := O + 2; + Output.Cursor := Output.Cursor + 2; + when 0 .. 7 | 14 .. 31 => + Escape (Data (I), Result, O); + Output.Cursor := Output.Cursor + 4; + when 16#80# .. 16#FF# => + case Output.Param.Char_Encoding is + when ASCII => + Escape (Data (I), Result, O); + Output.Cursor := Output.Cursor + 4; + when Latin => + if Data (I) in 16#80# .. 16#9F# then + Escape (Data (I), Result, O); + Output.Cursor := Output.Cursor + 4; + else + Result (O) := Data (I); + O := O + 1; + Output.Cursor := Output.Cursor + 1; + end if; + when UTF_8 => + C := UTF_Character_Size (Data, I); + if C = 0 then + Escape (Data (I), Result, O); + Output.Cursor := Output.Cursor + 4; + else + Result (O .. O + C - 1) := Data (I .. I + C - 1); + O := O + C; + I := I + C - 1; + Output.Cursor := Output.Cursor + 1; + end if; + end case; + when others => + Result (O) := Data (I); + O := O + 1; + Output.Cursor := Output.Cursor + 1; + end case; + + if not Single_Line + and then Output.Param.Width > 0 + and then Output.Cursor >= Output.Param.Width + then + Result (O) := Encodings.Escape; + case Output.Param.Newline is + when CR => + Result (O + 1) := Encodings.CR; + O := O + 2; + when LF => + Result (O + 1) := Encodings.LF; + O := O + 2; + when CR_LF => + Result (O + 1) := Encodings.CR; + Result (O + 2) := Encodings.LF; + O := O + 3; + when LF_CR => + Result (O + 1) := Encodings.LF; + Result (O + 2) := Encodings.CR; + O := O + 3; + end case; + Output.Cursor := 1; + end if; + + I := I + 1; + end loop; + + pragma Assert (O = Result'Last); + Result (O) := Encodings.Quoted_Atom_End; + + Output.Stream.Write (Result); + end; + end Write_Quoted; + + + procedure Write_Verbatim (Output : in out Printer; Data : in Atom) is + Length_Image : constant String := Count'Image (Data'Length); + Prefix : Atom (0 .. Length_Image'Length - 1); + begin + for I in Length_Image'First + 1 .. Length_Image'Last loop + Prefix (Count (I) - Count (Length_Image'First + 1)) := + Character'Pos (Length_Image (I)); + end loop; + Prefix (Prefix'Last) := Encodings.Verbatim_Begin; + + Output.Stream.Write (Prefix); + Output.Stream.Write (Data); + Output.Cursor := Output.Cursor + Screen_Offset (Prefix'Length) + + Screen_Offset (Data'Length); + end Write_Verbatim; + + + + ----------------------- + -- Printer Interface -- + ----------------------- + + overriding procedure Open_List (Output : in out Printer) is + begin + if not Output.First then + if Output.Param.Newline_At (Output.Previous, Opening) then + Newline (Output); + elsif Output.Param.Space_At (Output.Previous, Opening) then + Output.Stream.Write ((0 => Encodings.Space)); + Output.Cursor := Output.Cursor + 1; + end if; + else + Output.First := False; + end if; + + Output.Stream.Write ((0 => Encodings.List_Begin)); + Output.Cursor := Output.Cursor + 1; + Output.Indent_Level := Output.Indent_Level + 1; + Output.Previous := Opening; + Output.Need_Blank := False; + end Open_List; + + + overriding procedure Append_Atom (Output : in out Printer; + Data : in Atom) + is + Blank_Width : Screen_Offset; + At_Origin : Boolean := False; + begin + if not Output.First then + if Output.Param.Newline_At (Output.Previous, Atom_Data) then + Newline (Output); + Output.Need_Blank := False; + At_Origin := True; + elsif Output.Param.Space_At (Output.Previous, Atom_Data) then + Output.Need_Blank := True; + end if; + else + Output.First := False; + Output.Need_Blank := False; + At_Origin := True; + end if; + Output.Previous := Atom_Data; + + if Output.Need_Blank then + Blank_Width := 1; + else + Blank_Width := 0; + end if; + + -- Token encoding if requested and possible + + if (Output.Param.Token = Extended_Token + and then Is_Extended_Token (Data)) + or else (Output.Param.Token = Standard_Token + and then Is_Standard_Token (Data)) + then + declare + Width : constant Screen_Offset + := Single_Line_Quoted_Width (Data, Output.Param.Char_Encoding) + - 2; + begin + if not At_Origin + and then not Fit_In_Line (Output, Blank_Width + Width) + then + Newline (Output); + elsif Output.Need_Blank then + Output.Stream.Write ((0 => Encodings.Space)); + Output.Cursor := Output.Cursor + 1; + end if; + Output.Stream.Write (Data); + Output.Cursor := Output.Cursor + Width; + Output.Need_Blank := True; + return; + end; + end if; + + -- Single-line quoted string if requested and possible + + if Output.Param.Quoted = Single_Line then + declare + Width : constant Screen_Offset + := Single_Line_Quoted_Width (Data, Output.Param.Char_Encoding); + begin + if Fit_In_Line (Output, Blank_Width + Width) then + if Output.Need_Blank then + Output.Stream.Write ((0 => Encodings.Space)); + end if; + Write_Quoted (Output, Data, True); + Output.Cursor := Output.Cursor + Blank_Width + Width; + Output.Need_Blank := False; + return; + end if; + + if Indent_Width (Output) + Width <= Output.Param.Width then + Newline (Output); + Write_Quoted (Output, Data, True); + Output.Cursor := Output.Cursor + Width; + Output.Need_Blank := False; + return; + end if; + end; + end if; + + -- Fall back on a universal token encoding + + declare + Size : Count; + begin + case Output.Param.Fallback is + when Base64 => + Size := (Data'Length + 2) / 3 * 4 + 2; + when Hexadecimal => + Size := Data'Length * 2 + 2; + when Verbatim => + declare + I : Count := 10; + begin + Size := 2; + while Data'Length >= I loop + Size := Size + 1; + I := I * 10; + end loop; + end; + end case; + + if Output.Param.Quoted = When_Shorter + and then Multi_Line_Quoted_Size (Output, Data) <= Size + then + if Output.Need_Blank then + Output.Stream.Write ((0 => Encodings.Space)); + Output.Cursor := Output.Cursor + 1; + end if; + Write_Quoted (Output, Data, False); + Output.Need_Blank := False; + return; + end if; + +-- if Output.Param.Quoted = When_Shorter then +-- String'Write (Output.Stream, +-- "{" & Count'Image (Size) & "|" +-- & Count'Image (Multi_Line_Quoted_Size (Output, Data)) & "}"); +-- end if; + + if not At_Origin + and then + not Fit_In_Line (Output, Blank_Width + Screen_Offset (Size)) + then + Newline (Output); + elsif Output.Need_Blank then + Output.Stream.Write ((0 => Encodings.Space)); + Output.Cursor := Output.Cursor + 1; + end if; + + case Output.Param.Fallback is + when Base64 => + Write_Base64 (Output, Data); + when Hexadecimal => + Write_Hex (Output, Data); + when Verbatim => + Write_Verbatim (Output, Data); + end case; + Output.Need_Blank := False; + end; + end Append_Atom; + + + overriding procedure Close_List (Output : in out Printer) is + begin + Output.Indent_Level := Output.Indent_Level - 1; + + if not Output.First then + if Output.Param.Newline_At (Output.Previous, Closing) then + Newline (Output); + elsif Output.Param.Space_At (Output.Previous, Closing) then + Output.Stream.Write ((0 => Encodings.Space)); + Output.Cursor := Output.Cursor + 1; + end if; + else + Output.First := False; + end if; + + Output.Stream.Write ((0 => Encodings.List_End)); + Output.Cursor := Output.Cursor + 1; + Output.Previous := Closing; + Output.Need_Blank := False; + end Close_List; + + + + --------------------------- + -- Configuration Methods -- + --------------------------- + + procedure Set_Parameters (Output : in out Printer; Param : in Parameters) is + begin + Output.Param := Param; + end Set_Parameters; + + + function Get_Parameters (Output : Printer) return Parameters is + begin + return Output.Param; + end Get_Parameters; + + + procedure Set_Width + (Output : in out Printer; + Width : in Screen_Offset) is + begin + Output.Param.Width := Width; + end Set_Width; + + + procedure Set_Newline_At + (Output : in out Printer; + Newline_At : in Entity_Separator) is + begin + Output.Param.Newline_At := Newline_At; + end Set_Newline_At; + + + procedure Set_Space_At + (Output : in out Printer; + Space_At : in Entity_Separator) is + begin + Output.Param.Space_At := Space_At; + end Set_Space_At; + + + procedure Set_Tab_Stop + (Output : in out Printer; + Tab_Stop : in Screen_Column) is + begin + Output.Param.Tab_Stop := Tab_Stop; + end Set_Tab_Stop; + + + procedure Set_Indentation + (Output : in out Printer; + Indentation : in Screen_Offset) is + begin + Output.Param.Indentation := Indentation; + end Set_Indentation; + + + procedure Set_Indent + (Output : in out Printer; + Indent : in Indent_Type) is + begin + Output.Param.Indent := Indent; + end Set_Indent; + + + procedure Set_Quoted + (Output : in out Printer; + Quoted : in Quoted_Option) is + begin + Output.Param.Quoted := Quoted; + end Set_Quoted; + + + procedure Set_Token + (Output : in out Printer; + Token : in Token_Option) is + begin + Output.Param.Token := Token; + end Set_Token; + + + procedure Set_Hex_Casing + (Output : in out Printer; + Hex_Casing : in Encodings.Hex_Casing) is + begin + Output.Param.Hex_Casing := Hex_Casing; + end Set_Hex_Casing; + + + procedure Set_Quoted_Escape + (Output : in out Printer; + Quoted_Escape : in Quoted_Escape_Type) is + begin + Output.Param.Quoted_Escape := Quoted_Escape; + end Set_Quoted_Escape; + + + procedure Set_Char_Encoding + (Output : in out Printer; + Char_Encoding : in Character_Encoding) is + begin + Output.Param.Char_Encoding := Char_Encoding; + end Set_Char_Encoding; + + + procedure Set_Fallback + (Output : in out Printer; + Fallback : in Atom_Encoding) is + begin + Output.Param.Fallback := Fallback; + end Set_Fallback; + + + procedure Set_Newline + (Output : in out Printer; + Newline : in Newline_Encoding) is + begin + Output.Param.Newline := Newline; + end Set_Newline; + +end Natools.S_Expressions.Printers.Pretty; ADDED src/natools-s_expressions-printers-pretty.ads Index: src/natools-s_expressions-printers-pretty.ads ================================================================== --- src/natools-s_expressions-printers-pretty.ads +++ src/natools-s_expressions-printers-pretty.ads @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013-2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.S_Expressions.Printers.Pretty provides an implementation of the -- +-- S-expression Printer interface, using user-defines perferences to pretty -- +-- print the S-expression into the output stream. -- +------------------------------------------------------------------------------ + +with Ada.Streams; + +with Natools.S_Expressions.Encodings; + +package Natools.S_Expressions.Printers.Pretty is + pragma Pure (Pretty); + + type Atom_Encoding is (Base64, Hexadecimal, Verbatim); + type Character_Encoding is (ASCII, Latin, UTF_8); + type Newline_Encoding is (CR, LF, CR_LF, LF_CR); + type Entity is (Opening, Atom_Data, Closing); + type Entity_Separator is array (Entity, Entity) of Boolean; + type Indent_Type is (Spaces, Tabs, Tabs_And_Spaces); + type Quoted_Escape_Type is (Hex_Escape, Octal_Escape); + type Quoted_Option is (When_Shorter, Single_Line, No_Quoted); + type Token_Option is (Extended_Token, Standard_Token, No_Token); + type Screen_Offset is new Natural; + + subtype Screen_Column is Screen_Offset range 1 .. Screen_Offset'Last; + + type Parameters is record + Width : Screen_Offset; + Newline_At : Entity_Separator; + Space_At : Entity_Separator; + Tab_Stop : Screen_Column; + Indentation : Screen_Offset; + Indent : Indent_Type; + Quoted : Quoted_Option; + Token : Token_Option; + Hex_Casing : Encodings.Hex_Casing; + Quoted_Escape : Quoted_Escape_Type; + Char_Encoding : Character_Encoding; + Fallback : Atom_Encoding; + Newline : Newline_Encoding; + end record; + + Canonical : constant Parameters; + + type Printer (Stream : access Ada.Streams.Root_Stream_Type'Class) is + new Printers.Printer with private; + + overriding procedure Open_List (Output : in out Printer); + overriding procedure Append_Atom + (Output : in out Printer; + Data : in Atom); + overriding procedure Close_List (Output : in out Printer); + + procedure Set_Parameters (Output : in out Printer; Param : in Parameters); + function Get_Parameters (Output : Printer) return Parameters; + + procedure Set_Width + (Output : in out Printer; + Width : in Screen_Offset); + procedure Set_Newline_At + (Output : in out Printer; + Newline_At : in Entity_Separator); + procedure Set_Space_At + (Output : in out Printer; + Space_At : in Entity_Separator); + procedure Set_Tab_Stop + (Output : in out Printer; + Tab_Stop : in Screen_Column); + procedure Set_Indentation + (Output : in out Printer; + Indentation : in Screen_Offset); + procedure Set_Indent + (Output : in out Printer; + Indent : in Indent_Type); + procedure Set_Quoted + (Output : in out Printer; + Quoted : in Quoted_Option); + procedure Set_Token + (Output : in out Printer; + Token : in Token_Option); + procedure Set_Hex_Casing + (Output : in out Printer; + Hex_Casing : in Encodings.Hex_Casing); + procedure Set_Quoted_Escape + (Output : in out Printer; + Quoted_Escape : in Quoted_Escape_Type); + procedure Set_Char_Encoding + (Output : in out Printer; + Char_Encoding : in Character_Encoding); + procedure Set_Fallback + (Output : in out Printer; + Fallback : in Atom_Encoding); + procedure Set_Newline + (Output : in out Printer; + Newline : in Newline_Encoding); + +private + + type Printer (Stream : access Ada.Streams.Root_Stream_Type'Class) is + new Printers.Printer with record + Param : Parameters; + Cursor : Screen_Column := 1; + Previous : Entity; + First : Boolean := True; + Indent_Level : Screen_Offset := 0; + Need_Blank : Boolean := False; + end record; + + Canonical : constant Parameters := + (Width => 0, + Newline_At => (others => (others => False)), + Space_At => (others => (others => False)), + Tab_Stop => 8, -- unused + Indentation => 0, + Indent => Spaces, -- unused + Quoted => No_Quoted, + Token => No_Token, + Hex_Casing => Encodings.Upper, -- unused + Quoted_Escape => Octal_Escape, -- unused + Char_Encoding => ASCII, -- unused + Fallback => Verbatim, + Newline => LF); -- unused + +end Natools.S_Expressions.Printers.Pretty;