-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 3, or (at your option) any later
-- version. The SPARK toolset is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-- Public License for more details. You should have received a copy of the GNU
-- General Public License distributed with the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

with GNAT.OS_Lib;
with GNAT.Strings;
with SPARK_IO;
with SPARK.Ada.Strings.Unbounded.Not_SPARK;
with Command_Line;
with Ada.Containers.Vectors;

use type SPARK_IO.File_Status;
use type Command_Line.Solver_T;

package body Victor_Wrapper is
   type Environment_T is record
      Victor_Binary     : E_Strings.T; -- Absolute path for vct.
      Prover_Binary     : E_Strings.T; -- Absolute path for alt-ergo.
      Library_Directory : E_Strings.T; -- Absolute path for the directory containing prelude.fdl,
                                       -- divmod.fdl and divmod.rul.
      Vcg_File_Exists   : Boolean;     -- True if a vcg file is present.
      Siv_File_Exists   : Boolean;     -- True if a siv file is present.
   end record;

   --  A wrapper around GNAT.OS_Lib.Locate_Exe_On_Path, which also
   --  generates a useful error message if the specified executable
   --  cannot be found.
   procedure Find_On_Path
     (Executable_Name : in     String;
      Found           :    out Boolean;
      Error           :    out E_Strings.T;
      Actual_Path     :    out E_Strings.T)
   is
      --# hide Find_On_Path;
      use type GNAT.OS_Lib.String_Access;
      Tmp : GNAT.OS_Lib.String_Access;
   begin
      Error := E_Strings.Empty_String;

      Tmp   := GNAT.OS_Lib.Locate_Exec_On_Path (Executable_Name);
      Found := Tmp /= null;

      --  Try again, with .exe appended.
      if not Found then
         Tmp   := GNAT.OS_Lib.Locate_Exec_On_Path (Executable_Name & ".exe");
         Found := Tmp /= null;
      end if;

      if not Found then
         Error := E_Strings.Copy_String ("Could not locate '");
         E_Strings.Append_String (Error, Executable_Name);
         E_Strings.Append_String (Error, "' on path.");
         Actual_Path := E_Strings.Empty_String;
      else
         Actual_Path := E_Strings.Copy_String (Tmp.all);
      end if;
   end Find_On_Path;

   --  Tries to open and close the given file and sets is_valid
   --  depending on success. The name of the file opened is
   --  'Basename & Extension', either of which can be blank.
   procedure Valid_File (Basename  : in     E_Strings.T;
                         Extension : in     String;
                         Is_Valid  :    out Boolean)
   --# global in out SPARK_IO.File_Sys;
   is
      Tmp_File   : SPARK_IO.File_Type := SPARK_IO.Null_File;
      Tmp_Status : SPARK_IO.File_Status;
      Tmp_Name   : E_Strings.T;
   begin
      Tmp_Name := Basename;
      E_Strings.Append_String (Tmp_Name, Extension);

      E_Strings.Open
        (File         => Tmp_File,
         Mode_Of_File => SPARK_IO.In_File,
         Name_Of_File => Tmp_Name,
         Form_Of_File => "",
         Status       => Tmp_Status);
      Is_Valid := Tmp_Status = SPARK_IO.Ok;

      if Is_Valid then
         --# accept Flow, 10, Tmp_File, "We're closing the file, so we don't care.";
         SPARK_IO.Close (Tmp_File, Tmp_Status);
         --# end accept;
         Is_Valid := Tmp_Status = SPARK_IO.Ok;
      end if;
   end Valid_File;

   --  Given a path, for example foo/bar/baz.vcg or foo/bar/, this
   --  function returns the underlying directory. Thus, in both cases,
   --  it will return "foo/bar/". Note the trailing slash.
   function Dirname (Filename : E_Strings.T) return E_Strings.T is
      Retval : E_Strings.T;
   begin
      Retval := Filename;
      if E_Strings.Get_Length (Filename) > 0 then
         for I in reverse E_Strings.Positions range E_Strings.Positions'First .. E_Strings.Get_Length (Filename) loop
            --# assert I <= E_Strings.Get_Length (Filename) and E_Strings.Get_Length (Filename) > 0;
            if E_Strings.Get_Element (Filename, I) = '/' or E_Strings.Get_Element (Filename, I) = '\' then
               Retval := E_Strings.Section (E_Str     => Filename,
                                            Start_Pos => E_Strings.Positions'First,
                                            Length    => I);
               exit;
            end if;
         end loop;
      end if;
      return Retval;
   end Dirname;

   --  This procedure will determine the location of the various
   --  binaries, libraries and other files necessary to run vct.  If
   --  anything is missing, the error string will be set accordingly.
   procedure Check_Environment
     (CL          : in     Command_Line.Command_Line_Data_T;
      Ok          :    out Boolean;
      Error       :    out E_Strings.T;
      Environment :    out Environment_T)
   --# global in out SPARK_IO.File_Sys;
   is
      Tmp : Boolean;

      --  A helper function to require a particular file. If it cannot
      --  be found then Ok and Error of the enclosing procedure are
      --  set accordingly.
      procedure Require_File (Basename  : in E_Strings.T;
                              Extension : in String)
      --# global in out Error;
      --#        in out Ok;
      --#        in out SPARK_IO.File_Sys;
      is
      begin
         if Ok then
            Valid_File (Basename, Extension, Ok);
            if not Ok then
               Error := E_Strings.Copy_String ("Could not find required file '");
               E_Strings.Append_Examiner_String (Error, Basename);
               E_Strings.Append_String (Error, Extension);
               E_Strings.Append_String (Error, "'");
            end if;
         end if;
      end Require_File;

   begin
      --  Initialise with some defaults.
      Environment :=
        Environment_T'
        (Victor_Binary     => E_Strings.Empty_String,
         Prover_Binary     => E_Strings.Empty_String,
         Library_Directory => E_Strings.Empty_String,
         Vcg_File_Exists   => False,
         Siv_File_Exists   => False);
      Error       := E_Strings.Empty_String;
      Ok          := True;

      --  Check for the existance of the vcg and siv files.
      Valid_File (CL.Unit_Name, ".vcg", Environment.Vcg_File_Exists);
      Valid_File (CL.Unit_Name, ".siv", Environment.Siv_File_Exists);

      --  Check that we've got at least a valid vcg file.
      if not Environment.Vcg_File_Exists then
         Ok    := False;
         Error := E_Strings.Copy_String ("Could not find a vcg file for unit '");
         E_Strings.Append_Examiner_String (Error, CL.Unit_Name);
         E_Strings.Append_Char (Error, ''');
      end if;

      --# assert True;

      --  Find vct
      if Ok then
         Find_On_Path (Executable_Name => "vct",
                       Found           => Ok,
                       Error           => Error,
                       Actual_Path     => Environment.Victor_Binary);
      end if;

      --# assert True;

      --  Find alt-ergo (or other supported solvers)
      if Ok then
         case CL.Solver is
            when Command_Line.Alt_Ergo =>
               Find_On_Path (Executable_Name => "alt-ergo",
                             Found           => Ok,
                             Error           => Error,
                             Actual_Path     => Environment.Prover_Binary);
            when Command_Line.CVC3 =>
               Find_On_Path (Executable_Name => "cvc3",
                             Found           => Ok,
                             Error           => Error,
                             Actual_Path     => Environment.Prover_Binary);
            when Command_Line.CVC4_SMTLIB1 | Command_Line.CVC4 =>
               Find_On_Path (Executable_Name => "cvc4",
                             Found           => Ok,
                             Error           => Error,
                             Actual_Path     => Environment.Prover_Binary);
            when Command_Line.Yices =>
               Find_On_Path (Executable_Name => "yices",
                             Found           => Ok,
                             Error           => Error,
                             Actual_Path     => Environment.Prover_Binary);
            when Command_Line.Z3 =>
               Find_On_Path (Executable_Name => "z3",
                             Found           => Ok,
                             Error           => Error,
                             Actual_Path     => Environment.Prover_Binary);
         end case;
      end if;

      --# assert True;

      --  Check for prelude.fdl, prelude.rul and divmod.rul
      if Ok then
         --  First we check for the files in their 'compiled'
         --  location.
         Environment.Library_Directory := Dirname (Environment.Victor_Binary);
         E_Strings.Append_String (Environment.Library_Directory, "../run/");
         Valid_File (Environment.Library_Directory, "prelude.fdl", Tmp);

         if not Tmp then
            --  If the prelude isn't there, the rest won't be
            --  either. Let's look into the 'installed' location
            --  instead.
            Environment.Library_Directory := Dirname (Environment.Victor_Binary);
            E_Strings.Append_String (Environment.Library_Directory, "../share/spark/");
         end if;

         Require_File (Environment.Library_Directory, "prelude.fdl");
         Require_File (Environment.Library_Directory, "prelude.rul");
         Require_File (Environment.Library_Directory, "divmod.rul");
      end if;
   end Check_Environment;

   procedure Execute (CL    : in     Command_Line.Command_Line_Data_T;
                      Ok    :    out Boolean;
                      Error :    out E_Strings.T) is
      Environment : Environment_T;

      --  This hidden procedure asseembles the Argument_List used to
      --  call vct from Environment and CL and then calls Spawn.
      procedure Do_Spawn
      --# global in     CL;
      --#        in     Environment;
      --#        in out Error;
      --#        in out Ok;
      is
         --# hide Do_Spawn;
         use type GNAT.Strings.String_List;
         use type GNAT.Strings.String_Access;

         type Interface_Mode_T is (SMTLIB, SMTLIB2);

         package SVec is new Ada.Containers.Vectors (Element_Type => GNAT.Strings.String_Access,
                                                     Index_Type   => Positive);

         --  Vector for all arguments passed to vct.
         Vct_Args : SVec.Vector := SVec.Empty_Vector;

         --  Directory containing prelude.fdl, etc.
         Victor_Library : constant String :=
           SPARK.Ada.Strings.Unbounded.Not_SPARK.To_String (E_Strings.To_Unbounded_String (Environment.Library_Directory));

         --  The name of the unit to translate with vct.
         Unit_Name : constant String :=
           SPARK.Ada.Strings.Unbounded.Not_SPARK.To_String (E_Strings.To_Unbounded_String (CL.Unit_Name));

         --  The actual invocation of the solver.
         Solver_Invocation : E_Strings.T;

         Interface_Mode : Interface_Mode_T;

      begin
         --  The most important argument, the solver. We also work out
         --  what kind of interface to use.
         Solver_Invocation := Environment.Prover_Binary;
         case CL.Solver is
            when Command_Line.Alt_Ergo =>
               if CL.Proof_Steps > 0 then
                  E_Strings.Append_String (Solver_Invocation, " -steps " & Natural'Image (CL.Proof_Steps));
               end if;
               Interface_Mode := SMTLIB;
            when Command_Line.CVC3 =>
               E_Strings.Append_String (Solver_Invocation, " -lang smt");
               Interface_Mode := SMTLIB;
            when Command_Line.CVC4_SMTLIB1 =>
               E_Strings.Append_String (Solver_Invocation, " --lang smtlib");
               Interface_Mode := SMTLIB;
            when Command_Line.CVC4 =>
               E_Strings.Append_String (Solver_Invocation, " --lang smtlib2");
               Interface_Mode := SMTLIB2;
            when Command_Line.Yices =>
               E_Strings.Append_String (Solver_Invocation, " -smt");
               Interface_Mode := SMTLIB;
            when Command_Line.Z3 =>
               E_Strings.Append_String (Solver_Invocation, " -smt");
               Interface_Mode := SMTLIB;
         end case;
         SVec.Append
           (Vct_Args,
            new String'("-prover-command=" &
                          SPARK.Ada.Strings.Unbounded.Not_SPARK.To_String (E_Strings.To_Unbounded_String (Solver_Invocation))));

         --  Standard arguments.
         SVec.Append (Vct_Args, new String'("-fuse-concls"));
         SVec.Append (Vct_Args, new String'("-decls=" & Victor_Library & "prelude.fdl"));
         SVec.Append (Vct_Args, new String'("-rules=" & Victor_Library & "prelude.rul"));
         SVec.Append (Vct_Args, new String'("-rules=" & Victor_Library & "divmod.rul"));
         SVec.Append (Vct_Args, new String'("-elim-enums"));
         SVec.Append (Vct_Args, new String'("-ground-eval-exp"));
         SVec.Append (Vct_Args, new String'("-abstract-exp"));
         SVec.Append (Vct_Args, new String'("-abstract-divmod"));
         SVec.Append (Vct_Args, new String'("-utick"));
         SVec.Append (Vct_Args, new String'("-gtick"));
         SVec.Append (Vct_Args, new String'("-gstime-inc-setup"));
         SVec.Append (Vct_Args, new String'("-longtick"));
         SVec.Append (Vct_Args, new String'("-echo-final-stats"));
         SVec.Append (Vct_Args, new String'("-csv-reports-include-unit-kind"));
         SVec.Append (Vct_Args, new String'("-level=warning"));

         --  General SMTLIB options. See vct/run/Makefile-prelude.mk
         --  for a mapping and ideas.

         --  A-D are only included in SMTLIB1; for SMTLIB2 they are
         --  skipped entirely.
         if Interface_Mode = SMTLIB then
            --  A
            SVec.Append (Vct_Args, new String'("-refine-bit-type-as-int-subtype"));

            --  B
            SVec.Append (Vct_Args, new String'("-refine-bit-eq-equiv"));

            --  C
            --  None.

            --  D
            --  None.
         end if;

         --  E
         SVec.Append (Vct_Args, new String'("-abstract-arrays-records-late"));

         --  F
         SVec.Append (Vct_Args, new String'("-elim-record-constructors"));
         SVec.Append (Vct_Args, new String'("-add-record-select-update-axioms"));
         SVec.Append (Vct_Args, new String'("-abstract-record-selects-updates"));

         --  G
         --  None.

         SVec.Append (Vct_Args, new String'("-logic=AUFNIRA"));

         --  Again, see vct/run/Makefile-prelude.mk
         case Interface_Mode is
            when SMTLIB =>
               SVec.Append (Vct_Args, new String'("-interface-mode=smtlib"));
               SVec.Append (Vct_Args, new String'("-bit-type"));
               SVec.Append (Vct_Args, new String'("-bit-type-bool-eq-to-iff"));
               SVec.Append (Vct_Args, new String'("-refine-types"));
               SVec.Append (Vct_Args, new String'("-refine-int-subrange-type"));
               SVec.Append (Vct_Args, new String'("-elim-array-constructors"));
               SVec.Append (Vct_Args, new String'("-add-array-select-box-update-axioms"));
               SVec.Append (Vct_Args, new String'("-abstract-array-box-updates"));
               SVec.Append (Vct_Args, new String'("-add-array-select-update-axioms"));
               SVec.Append (Vct_Args, new String'("-abstract-array-select-updates"));
               SVec.Append (Vct_Args, new String'("-abstract-array-types"));
               SVec.Append (Vct_Args, new String'("-abstract-record-types"));
               SVec.Append (Vct_Args, new String'("-abstract-bit-ops"));
               SVec.Append (Vct_Args, new String'("-abstract-bit-valued-eqs"));
               SVec.Append (Vct_Args, new String'("-abstract-bit-valued-int-le"));
               SVec.Append (Vct_Args, new String'("-elim-bit-type-and-consts"));
               SVec.Append (Vct_Args, new String'("-abstract-reals"));
               SVec.Append (Vct_Args, new String'("-lift-quants"));
               SVec.Append (Vct_Args, new String'("-strip-quantifier-patterns"));
               SVec.Append (Vct_Args, new String'("-elim-type-aliases"));

               --  Extra arguments for the various provers. See
               --  vct/run/Makefile-prelude.mk for more information.
               case CL.Solver is
                  when Command_Line.Yices =>
                     SVec.Append (Vct_Args, new String'("-abstract-nonlin-times"));
                     SVec.Append (Vct_Args, new String'("-logic=AUFLIA"));
                  when others =>
                     null;
               end case;

            when SMTLIB2 =>
               SVec.Append (Vct_Args, new String'("-interface-mode=smtlib2"));
               SVec.Append (Vct_Args, new String'("-refine-types"));
               SVec.Append (Vct_Args, new String'("-refine-int-subrange-type"));
               SVec.Append (Vct_Args, new String'("-elim-array-constructors"));
               SVec.Append (Vct_Args, new String'("-add-array-select-box-update-axioms"));
               SVec.Append (Vct_Args, new String'("-abstract-array-box-updates"));
               SVec.Append (Vct_Args, new String'("-add-array-select-update-axioms"));
               SVec.Append (Vct_Args, new String'("-abstract-array-select-updates"));
               SVec.Append (Vct_Args, new String'("-abstract-array-types"));
               SVec.Append (Vct_Args, new String'("-abstract-record-types"));
               SVec.Append (Vct_Args, new String'("-lift-quants"));
               SVec.Append (Vct_Args, new String'("-strip-quantifier-patterns"));

               --  Extra arguments for the various provers. See
               --  vct/run/Makefile-prelude.mk for more information.
               case CL.Solver is
                  when Command_Line.Alt_Ergo =>
                     SVec.Append (Vct_Args, new String'("-elim-type-aliases"));
                     SVec.Append (Vct_Args, new String'("-smtlib2-add-to_real-decl"));
                  when Command_Line.CVC3 =>
                     SVec.Append (Vct_Args, new String'("-elim-type-aliases"));
                     SVec.Append (Vct_Args, new String'("-smtlib2-omit-set-option-command"));
                     SVec.Append (Vct_Args, new String'("-smtlib2-add-to_real-decl"));
                  when others =>
                     null;
               end case;

         end case;

         if CL.Time_Out > 0 then
            SVec.Append (Vct_Args, new String'("-ulimit-timeout=" & Natural'Image (CL.Time_Out)));
         end if;

         if CL.Memory_Limit > 0 then
            --  Remember, we store the memory limit in megabytes, so
            --  we need to multiply by 1024 here.  This multiplication
            --  is safe because the range of Memory_Limit_T is chosen
            --  appropriately.
            SVec.Append (Vct_Args, new String'("-ulimit-memory=" & Natural'Image (CL.Memory_Limit * 1024)));
         end if;

         --  If there is a siv file and -v has not been specified, we
         --  should look at that instead.
         if Environment.Siv_File_Exists and not CL.Ignore_SIV then
            SVec.Append (Vct_Args, new String'("-siv"));
         end if;

         if CL.Plain then
            SVec.Append (Vct_Args, new String'("-plain"));
         else
            SVec.Append (Vct_Args, new String'("-gstime"));
         end if;

         if CL.User_Rules then
            SVec.Append (Vct_Args, new String'("-read-unit-rlu-files"));
            SVec.Append (Vct_Args, new String'("-read-directory-rlu-files"));

            --  Global rules likely contain rules with identifiers
            --  which are relevant to only some programs, so we better
            --  delete the ones we don't know about. (Otherwise vct
            --  will abort with an FDL normalisation error).
            SVec.Append (Vct_Args, new String'("-delete-rules-with-undeclared-ids"));
         end if;

         if CL.Keep_Temp then
            SVec.Append (Vct_Args, new String'("-flat-working-files"));
            SVec.Append (Vct_Args, new String'("-working-dir=."));
         else
            SVec.Append (Vct_Args, new String'("-unique-working-files"));
            SVec.Append (Vct_Args, new String'("-delete-working-files"));
         end if;

         --  Finally, we add the unit to analyse to the arguments.
         SVec.Append (Vct_Args, new String'("-report=" & Unit_Name));
         SVec.Append (Vct_Args, new String'(Unit_Name));

         --  Other misc. setup below.

         if CL.Solver = Command_Line.Alt_Ergo then
            --  In order for alt-ergo to avoid using the hard-coded
            --  path, we set the ERGOLIB environment variable to point
            --  to the same location where the prelude.fdl, etc. files
            --  are contained.
            GNAT.OS_Lib.Setenv (Name  => "ERGOLIB",
                                Value => Victor_Library);
         end if;

         --  At last; run vct with the given arguments.
         declare
            subtype Arg_Index is Positive range 1 .. Positive (SVec.Length (Vct_Args));
            subtype Arg_List_T is GNAT.OS_Lib.Argument_List (Arg_Index);
            Args : Arg_List_T;
         begin
            --  Copy the argument list.
            for I in Arg_Index loop
               Args (I) := SVec.Element (Vct_Args, I);
            end loop;

            --  This is not strictly necessary since Spawn itself
            --  calls this, but if the Spawn call fails we want to
            --  print out the arguments exactly as used by Spawn.
            GNAT.OS_Lib.Normalize_Arguments (Args);

            GNAT.OS_Lib.Spawn
              (Program_Name => SPARK.Ada.Strings.Unbounded.Not_SPARK.To_String (E_Strings.To_Unbounded_String (Environment.Victor_Binary)),
               Args         => Args,
               Success      => Ok);

            --  Set a useful error message, containing all the
            --  arguments used.
            if not Ok then
               Error := E_Strings.Copy_String ("Program '");
               E_Strings.Append_Examiner_String (Error, Environment.Victor_Binary);
               E_Strings.Append_String (Error, "' could not be spawned. Arguments were:");
               for I in Positive range Args'Range loop
                  E_Strings.Append_Char (Error, ' ');
                  E_Strings.Append_String (Error, Args (I).all);
               end loop;
            end if;
         end;
      end Do_Spawn;

   begin
      --  Check some basic stuff, including presence of binaries and vcg/siv files.
      Check_Environment (CL          => CL,
                         Ok          => Ok,
                         Error       => Error,
                         Environment => Environment);

      --  Proceed only if everything is in order.
      if Ok then
         Do_Spawn;
      end if;
   end Execute;

end Victor_Wrapper;
