-- -*- coding: utf-8 -*- -- -- ZanyBlue, an Ada library and framework for finite element analysis. -- -- Copyright (c) 2012, 2016, Michael Rohan -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions -- are met: -- -- * Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- * Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- -- * Neither the name of ZanyBlue nor the names of its contributors may -- be used to endorse or promote products derived from this software -- without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- with Ada.Wide_Wide_Characters.Unicode; with Ada.Containers.Indefinite_Vectors; ---------------------------------- -- ZanyBlue.Text.Format_Message -- ---------------------------------- function ZanyBlue.Text.Format_Message (Message : String; Arguments : ZanyBlue.Text.Arguments.Argument_List; Mapping : ZanyBlue.Text.Pseudo.Pseudo_Map_Access; Locale : ZanyBlue.Text.Locales.Locale_Type; Raise_Errors : Boolean := True; Mark_Messages : Boolean := True; Mark_Arguments : Boolean := True; Error_Handler : access Error_Handler_Type'Class := Standard_Error_Handler'Access) return String is use Ada.Wide_Wide_Characters.Unicode; use ZanyBlue.Text.Pseudo; use ZanyBlue.Text.Locales; use ZanyBlue.Text.Arguments; Done : exception; -- End of input is signaled by raising the Done exception. type Source_Buffer (Length : Natural) is record Buffer : String; Position : Positive := 1; end record; -- The "stream of characters" being formatted is simply the input -- format string, Message, but is augmented in the case of nested -- arguments, e.g, "X: {0,{1}}" to format a value within a field -- width which is, itself, an argument. Such nested arguments are -- handled by maintaining a stack of string sources. When expanding -- an argument, if another reference is encountered, the value of -- the reference is then pushed onto a stack of strings being -- processed. The Source_Buffer is the record type used to store -- these nested references. The Position is used to track the -- current character being consumed. package Source_Stacks is new Ada.Containers.Indefinite_Vectors (Index_Type => Positive, Element_Type => Source_Buffer); -- The stack of source strings is managed by a simple vector. use Ada.Containers; use Source_Stacks; Zero : constant Natural := Unicode_Character'Pos ('0'); -- Offset value when converting a string of decimal digits to an integer. procedure Add_Argument (Buffer : in out String; Value : String); -- Add a formatted argument value to the output buffer. function Buffered_Next (Last_Buffer : Natural) return Unicode_Character; -- Get the next character. There are recursive references to -- formatted values so a stack is in use to manage them. This routine -- accesses the stack to get the character. function Character_Mapping (Ch : Unicode_Character) return Unicode_Character; -- Return the pseudo translation mapping for a given character. The -- same character is returned if pseudo translation is not enabled. function Next return Unicode_Character; -- Return the next character from the format string. Calls the -- Buffered_Next procedure if the stack of sources is in use, i.e., -- recursive references to arguments, e.g., "{0:{1}}" function Parse_Argument (Level : Natural := 0) return String; -- Parse the an argument reference: argument number and format -- template. procedure Pseudo_Append (Buffer : in out String; Ch : Unicode_Character; Enabled : Boolean); -- Append a character to the output buffer if pseudo translation -- is enabled, otherwise do nothing. procedure Push_Source (Data : String); -- Add a new format character source used to handle recursive format -- references, e.g., "{0:{1}}" Source_Stack : Source_Stacks.Vector; Buffer : String; Ch : Unicode_Character; I : Positive := Message.First; ------------------ -- Add_Argument -- ------------------ procedure Add_Argument (Buffer : in out String; Value : String) is begin Pseudo_Append (Buffer, Format_Start, Mark_Arguments); Append (Buffer, Value); Pseudo_Append (Buffer, Format_End, Mark_Arguments); end Add_Argument; ------------------- -- Buffered_Next -- ------------------- function Buffered_Next (Last_Buffer : Natural) return Unicode_Character is Found : Boolean := False; Result : Unicode_Character; procedure Get_Character (Buffer : in out Source_Buffer); -- Get a character for a buffer source. ------------------- -- Get_Character -- ------------------- procedure Get_Character (Buffer : in out Source_Buffer) is begin if Buffer.Position <= Buffer.Buffer.Last then Result := Buffer.Buffer (Buffer.Position); Buffer.Position := Buffer.Position + 1; Found := True; end if; end Get_Character; begin Update_Element (Source_Stack, Last_Buffer, Get_Character'Access); if not Found then Delete_Last (Source_Stack); Result := Next; end if; return Result; end Buffered_Next; ----------------------- -- Character_Mapping -- ----------------------- function Character_Mapping (Ch : Unicode_Character) return Unicode_Character is begin if Mapping /= null then return Mapping.Map (Ch); else return Ch; end if; end Character_Mapping; ---------- -- Next -- ---------- function Next return Unicode_Character is Last_Buffer : constant Natural := Natural (Length (Source_Stack)); Result : Unicode_Character; begin if Last_Buffer = 0 then if I > Message.Last then raise Done; end if; Result := Message (I); I := I + 1; else Result := Buffered_Next (Last_Buffer); end if; return Result; end Next; -------------------- -- Parse_Argument -- -------------------- function Parse_Argument (Level : Natural := 0) return String is function Next_Character return Unicode_Character; -- Return the next format character. If the character is '{' then -- it's a recursive format reference: format the argument value and -- add to the stack, then return the next chararacter. -------------------- -- Next_Character -- -------------------- function Next_Character return Unicode_Character is Result : Unicode_Character := Next; begin while Result = '{' loop Push_Source (Parse_Argument (Level => Level + 1)); Result := Next; end loop; return Result; end Next_Character; Template : String; Index : Natural := 0; Ch : Unicode_Character; begin Template := Null_UXString; Ch := Next_Character; if not Is_Digit (Ch) then Error_Handler.Illegal_Character (Message, I - Message.First + 1, Ch, Natural (Length (Source_Stack)), Raise_Errors); -- If an exception was not raised, skip to next closing brace while Ch /= '}' loop Ch := Next_Character; end loop; end if; while Is_Digit (Ch) loop Index := Index * 10 + Unicode_Character'Pos (Ch) - Zero; Ch := Next_Character; end loop; if Ch = ',' or else Ch = ':' then Ch := Next_Character; while Ch /= '}' loop Append (Template, Ch); Ch := Next_Character; end loop; else if Ch /= '}' then Error_Handler.Format_Not_Closed (Message, I - Message.First + 1, Natural (Length (Source_Stack)), Raise_Errors); end if; end if; return Arguments.Format (Index, Message, Template, Locale, Raise_Errors, Error_Handler => Error_Handler); exception when Done => Error_Handler.Format_Not_Closed (Message, I - Message.First + 1, Natural (Length (Source_Stack)), Raise_Errors); -- If the handler decided not to raise an exception, re-raise the Done -- exception raise Done; end Parse_Argument; ------------------- -- Pseudo_Append -- ------------------- procedure Pseudo_Append (Buffer : in out String; Ch : Unicode_Character; Enabled : Boolean) is begin if Enabled and then Mapping /= null then Append (Buffer, Ch); end if; end Pseudo_Append; ----------------- -- Push_Source -- ----------------- procedure Push_Source (Data : String) is New_Buffer : Source_Buffer (Data.Length); begin New_Buffer.Buffer := Data; Append (Source_Stack, New_Buffer); end Push_Source; begin Pseudo_Append (Buffer, Pseudo_Start, Mark_Messages); <> Ch := Next; case Ch is when ''' => goto Quote; when '{' => goto FormatElement; when others => Append (Buffer, Character_Mapping (Ch)); goto String; end case; <> Ch := Next; case Ch is when ''' => Append (Buffer, '''); goto String; when others => Append (Buffer, Character_Mapping (Ch)); goto QuotedString; end case; <> Ch := Next; case Ch is when ''' => goto String; when others => Append (Buffer, Character_Mapping (Ch)); goto QuotedString; end case; <> Add_Argument (Buffer, Parse_Argument); goto String; exception when Done => Pseudo_Append (Buffer, Pseudo_End, Mark_Messages); return Buffer; end ZanyBlue.Text.Format_Message;