with Unicode.CES;           use Unicode.CES;
with Ada.Strings.Unbounded;

package body Schema.Validators.Facets is

   function Convert_Regexp (Regexp : String) return String;
   --  Return a regular expresssion that converts the XML-specification
   --  regexp Regexp to a GNAT.Regpat compatible one

   --------------------
   -- Convert_Regexp --
   --------------------

   function Convert_Regexp (Regexp : String) return String is
      use Ada.Strings.Unbounded;
      Result : Unbounded_String;
      Pos    : Integer := Regexp'First;
   begin
      while Pos <= Regexp'Last loop
         if Regexp (Pos) = '\' then
            case Regexp (Pos + 1) is
               when 'i' =>
                  Result := Result & "[A-Za-z:_]";
                  Pos := Pos + 1;

               when 'c' =>
                  Result := Result & "[:a-zA-Z0-9._-]";
                  Pos    := Pos + 1;

               when others =>
                  Result := Result & Regexp (Pos);
            end case;
         else
            Result := Result & Regexp  (Pos);
         end if;

         Pos := Pos + 1;
      end loop;

      return To_String (Result);
   end Convert_Regexp;

   ----------
   -- Free --
   ----------

   procedure Free (Facets : in out Common_Facets_Description) is
   begin
      if Facets.Pattern /= null then
         Unchecked_Free (Facets.Pattern);
         Free (Facets.Pattern_String);
      end if;

      if Facets.Enumeration /= null then
         Free (Facets.Enumeration);
      end if;
   end Free;

   -----------------
   -- Check_Facet --
   -----------------

   procedure Check_Facet
     (Facets : in out Common_Facets_Description;
      Value  : Unicode.CES.Byte_Sequence)
   is
      Found : Boolean;
      Matched : Match_Array (0 .. 0);
   begin
      if Facets.Mask (Facet_Pattern) then
         if Facets.Pattern = null then
            Facets.Pattern := new Pattern_Matcher '
              (Compile (Convert_Regexp (Facets.Pattern_String.all)));
         end if;
         Match (Facets.Pattern.all, String (Value), Matched);
         if Matched (0).First /= Value'First
           or else Matched (0).Last /= Value'Last
         then
            Validation_Error ("string pattern not matched: "
                              & Facets.Pattern_String.all);
         end if;
      end if;

      if Facets.Mask (Facet_Enumeration) then
         Found := False;
         for E in Facets.Enumeration'Range loop
            if Value = Facets.Enumeration (E).all then
               Found := True;
            end if;
         end loop;

         if not Found then
            Validation_Error ("Element's value not in the enumeration set");
         end if;
      end if;

      if Facets.Mask (Facet_Implicit_Enumeration) then
         if not Facets.Implicit_Enumeration (Value) then
            Validation_Error ("Invalid value: """ & Value & """");
         end if;
      end if;

      if Facets.Mask (Facet_Whitespace) then
         case Facets.Whitespace is
            when Preserve =>
               null; --  Always valid

            when Replace =>
               for C in Value'Range loop
                  if Value (C) = ASCII.HT
                    or else Value (C) = ASCII.LF
                    or else Value (C) = ASCII.CR
                  then
                     Validation_Error ("HT, LF and CR characters not allowed");
                  end if;
               end loop;

            when Collapse =>
               for C in Value'Range loop
                  if Value (C) = ASCII.HT
                    or else Value (C) = ASCII.LF
                    or else Value (C) = ASCII.CR
                  then
                     Validation_Error ("HT, LF and CR characters not allowed");

                  elsif Value (C) = ' '
                    and then C < Value'Last
                    and then Value (C + 1) = ' '
                  then
                     Validation_Error
                       ("Duplicate space characters not allowed");
                  end if;
               end loop;

               --  Leading or trailing white spaces are also forbidden
               if Value'Length /= 0 then
                  if Value (Value'First) = ' ' then
                     Validation_Error ("Leading whitespaces not allowed");
                  elsif Value (Value'Last) = ' ' then
                     Validation_Error ("Trailing whitespaces not allowed");
                  end if;
               end if;
         end case;
      end if;
   end Check_Facet;

   ---------------
   -- Add_Facet --
   ---------------

   procedure Add_Facet
     (Facets      : in out Common_Facets_Description;
      Facet_Name  : Unicode.CES.Byte_Sequence;
      Facet_Value : Unicode.CES.Byte_Sequence;
      Applied     : out Boolean) is
   begin
      Applied := False;
      if Facet_Name = "enumeration" then
         if not Facets.Settable (Facet_Enumeration) then
            Validation_Error ("Enumeration facet can't be set for this type");
         end if;
         Append (Facets.Enumeration, Facet_Value);
         Facets.Mask (Facet_Enumeration) := True;
         Applied := True;

      elsif Facet_Name = "whiteSpace" then
         if not Facets.Settable (Facet_Whitespace) then
            Validation_Error ("whiteSpace facet can't be set for this type");
         end if;
         if Facet_Value = "preserve" then
            Facets.Whitespace := Preserve;
         elsif Facet_Value = "replace" then
            Facets.Whitespace := Replace;
         elsif Facet_Value = "collapse" then
            Facets.Whitespace := Collapse;
         else
            Validation_Error
              ("Invalid value for whiteSpace facet: " & Facet_Value);
         end if;
         Facets.Mask (Facet_Whitespace) := True;
         Applied := True;

      elsif Facet_Name = "pattern" then
         if not Facets.Settable (Facet_Pattern) then
            Validation_Error ("pattern facet can't be set for this type");
         end if;
         Unchecked_Free (Facets.Pattern);
         Free (Facets.Pattern_String);
         Facets.Pattern := null;
         Facets.Pattern_String := new Byte_Sequence'(Facet_Value);
         Facets.Mask (Facet_Pattern) := True;
         Applied := True;
      end if;
   end Add_Facet;

   ------------------------------
   -- Set_Implicit_Enumeration --
   ------------------------------

   procedure Set_Implicit_Enumeration
     (Facets      : in out Common_Facets_Description;
      Validator   : Value_Validator) is
   begin
      Facets.Mask (Facet_Implicit_Enumeration) := True;
      Facets.Implicit_Enumeration := Validator;
   end Set_Implicit_Enumeration;

   --------------------
   -- Set_Whitespace --
   --------------------

   procedure Set_Whitespace
     (Facets     : in out Common_Facets_Description;
      Whitespace : Whitespace_Restriction) is
   begin
      Facets.Mask (Facet_Whitespace) := True;
      Facets.Whitespace := Whitespace;
   end Set_Whitespace;

   ------------
   -- Append --
   ------------

   procedure Append
     (List  : in out Byte_Sequence_List_Access;
      Value : Unicode.CES.Byte_Sequence)
   is
      L : Byte_Sequence_List_Access := List;
   begin
      if List /= null then
         L := new Byte_Sequence_List'(List.all & new Byte_Sequence'(Value));
         Unchecked_Free (List);
         List := L;
      else
         List := new Byte_Sequence_List'(1 => new Byte_Sequence'(Value));
      end if;
   end Append;

   ----------
   -- Free --
   ----------

   procedure Free (List : in out Byte_Sequence_List_Access) is
   begin
      if List /= null then
         for L in List'Range loop
            Free (List (L));
         end loop;

         Unchecked_Free (List);
      end if;
   end Free;

end Schema.Validators.Facets;
