;;; GNU Guix --- Ada compiler for Guix
;;;
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2024 Adrien Bourmault <neox@gnu.org>
;;;
;;; This file is NOT part of GNU Guix.
;;;
;;; This is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This 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
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (ada)
  #:use-module (gnu packages)
  #:use-module (gnu packages bootstrap)
  #:use-module (gnu packages elf)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages gcc)
  #:use-module (gnu packages commencement)
  #:use-module (gnu packages perl)
  #:use-module (guix base16)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system copy)
  #:use-module (guix download)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (ice-9 match))

;;; Debian GNAT bootstrap binary

(define %debian-mirror "http://archive.debian.org/debian")

(define (debian-url source name version)
  (string-append %debian-mirror "/pool/main/" (substring source 0 1) "/"
                 source "/" name "_" version "_amd64.deb"))

(define %debian-gcc-packages
  '(("libasan1"
     "ea0c7defc2fbbb61f069a5d119a3e3e5c9740f7fafd5214bf3065aa8cb971097")
    ("libatomic1"
     "92d74070442f13a2e9403464862e1b0b1bb23992e5157e2ac83cc4ac9f17084a")
    ("libcilkrts5"
     "a0d57dd6273ef2366ba8b54669ac147226e24238e40c2c4a39a3e0e2a7eacb99")
    ("cpp-4.9"
     "f1b38be5b85df78265bba28dae8987b72904b7d36051703bc1f7e70c55136a91")
    ("gcc-4.9"
     "569a2ca8aed7eca54fbb9edae367064bbb0f7f773973e73c72e27fbfc703c3b0")
    ("libgomp1"
     "5e4425acbd597a4f091c69e787a9ea16f8bf4442c1dfd795d1ac8669912f2851")
    ("libitm1"
     "c005a4b836179ca9aa6ed28d9cb8785a3af6daa222cb55563fcc1edbca081eb4")
    ("libgcc-4.9-dev"
     "db89814eb484edf5d9c24a9def334ca1eac22afbfd3f8b23f12262e217ac80ff")
    ("libgcc1"
     "3101d5dc171fab3b4601bc3282bbc69f0fb9cfd1e1761389e1e6d2590e384623")
    ("libstdc++6"
     "a8f4ef6773b90bb39a8a8a0a5e3e20ca8501de6896204f665eb114d5b79f164f")
    ("liblsan0"
     "20caadf3fdd5905618f9933768bdbd79b9c16a26ece2774ad1b38d14329ecdf2")
    ("libquadmath0"
     "7e3779d41a42a88621f93c47a77874547b266b7c8166c80e254721e8347c3355")
    ("libtsan0"
     "5574f38d9b2f4987b90a70003ea7e60e0b5cab5c7a7c6ac9c2837eb1353e71bf")
    ("libubsan0"
     "49f00199613ff3d214c4137a2fe3b43bc3bbee79fa92ed9fb9cd0b0abaaf7c3e")))

(define %debian-gnat-packages
  '(("gnat-4.9"
     "0afb887980b819853f04e6c674f1a962836e3f691f14ad2b93af93c432db4bcb")
    ("libgnat-4.9"
     "9d6258a9dea4e78d4e6bd9996e00f673f1169df1aa00db713c716f22011b3638")
    ("libgnatprj4.9"
     "cadaf3f8d5f150589cbb286ecca07f1cd2f33b2f52675326398c9e1fb3b9aba5")
    ("libgnatvsn4.9"
     "227eaf2a40c24c9222e2f658d8b02e24e5f0d82f4c9003f994421c19c13f040d")))

(define %debian-gnat-closure
  `(("cloog" "libcloog-isl4" "0.18.2-1+b2"
     "8bb4ba985d65ededbfc24d76d3610af57a70787b635841407558d25a7f06ff49")
    ("gmp" "libgmp10" "6.0.0+dfsg-6"
     "155a31b0f716aa3dcd7ee68e9bd57e0b76a6b31f4e41fb2d953e986315437082")
    ("isl" "libisl10" "0.12.2-2"
     "5a091cf30221e183d319f4906a746043be7220061f3b742b2ad958ee79ac01f7")
    ("mpclib3" "libmpc3" "1.0.2-1"
     "0a252dcf89843ee8b402fd226c8fb552d69c82c7013a28e335ba36878468d959")
    ("mpfr4" "libmpfr4" "3.1.2-2"
     "1b6ef16024e7850c4f2d47dbe06cba1143ac36d5584db515f63d5fbd873e3eb2")
    ("zlib" "zlib1g" "1.2.8.dfsg-2+b1"
     "b75102f61ace79c14ea6f06fdd9509825ee2af694c6aa503253df4e6659d6772")
    ("gcc-defaults" "gcc" "4.9.2-2"
     "b7a60f9bc12d8ac0bbce99160390f28ee4a2d1d94753d123a7016d0443e46518")
    ("gcc-defaults" "cpp" "4.9.2-2"
     "e0d777817359da6dd7d003c164f12a55a8b889eb360ba2c945d5316ee7dbefd8")
    ,@(map (match-lambda
             ((name hash)
              `("gcc-4.9" ,name "4.9.2-10+deb8u1" ,hash)))
           %debian-gcc-packages)
    ,@(map (match-lambda
             ((name hash)
              `("gnat-4.9" ,name "4.9.2-1" ,hash)))
           %debian-gnat-packages)))

(define-public gnat-debian
  (package
    (name "gnat-debian")
    (version "4.9.2-1")
    (source #f)
    (build-system gnu-build-system)
    (arguments
      `(#:tests? #f
        #:validate-runpath? #t
        #:validate-runpath? #t
        #:strip-binaries? #f
        #:modules ((ice-9 match)
                  ,@%default-gnu-imported-modules)
        #:phases
        (modify-phases %standard-phases
         ;; Instead of a single source archive, unpack many archives
         (replace 'unpack
           (lambda* (#:key inputs #:allow-other-keys)
             (for-each
               (match-lambda
                 ((name . value)
                   (when (string-suffix? ".deb" name)
                     (invoke "ar" "x" value)
                     (invoke "tar" "xvf" "data.tar.xz"))))
               inputs)
             ;; Most of the libraries are in "/usr/lib" but a few are in
             ;; "/lib". They are easier to work with if consolidated.
             (copy-recursively "lib" "usr/lib")
             #t))

         ;; Make absolute simlink to "libgcc_s.so" relative
         (add-after 'unpack 'fix-libgcc_s-link
           (lambda _
             (with-directory-excursion "usr//lib/gcc/x86_64-linux-gnu/4.9"
               (delete-file "libgcc_s.so")
               (symlink "../../../x86_64-linux-gnu/libgcc_s.so.1"
                        "libgcc_s.so"))
             #t))
             
         ;; (This follows the Rust bootstrap binary packages)
         ;; Patch binaries to find shared libraries and dynamic linker
         (add-after 'configure 'patch-elf-binaries
           (lambda* (#:key inputs outputs #:allow-other-keys)
             (let* ((out (assoc-ref outputs "out"))
                    (ld-so
                      (string-append 
                        (assoc-ref inputs "libc") 
                        ,(glibc-dynamic-linker)))
                    (rpath 
                      (string-append 
                        out
                        "/lib/x86_64-linux-gnu:"
                        (dirname ld-so)))
                    (elf-binaries
                      (find-files "."
                        (lambda (file stat)
                          (and (not (string-suffix? ".o" file))
                               (elf-file? file))))))
               (for-each
                 (lambda (elf)
                   (format #t "set RUNPATH for ~a~%" elf)
                   (invoke "patchelf" "--set-rpath" rpath elf)
                   (when (with-output-to-port (%make-void-port "w")
                     (lambda ()
                       (zero? (system* "patchelf" "--print-interpreter" elf))))
                   (format #t "set interpreter for ~a~%" elf)
                   (invoke "patchelf" "--set-interpreter" ld-so elf)))
                 elf-binaries)
               #t)))
        
         ;; Nothing to configure nor build here
         (delete 'configure)
         (delete 'build)
         
         ;; Just copying files
         (replace 'install
           (lambda* (#:key outputs #:allow-other-keys)
             (let ((out (assoc-ref outputs "out")))
               (copy-recursively "usr" out)
               #t)))

         ;; The easiest way to ensure that GNAT uses Guix's dynamic
         ;; linker is to wrap the "collect2" program and modify its
         ;; arguments. Normally, one would use LDFLAGS to set it, but
         ;; this doesn't propagate through the GNAT tools (e.g.,
         ;; "gnatmake")
         (add-after 'install 'wrap-collect
           (lambda* (#:key inputs outputs #:allow-other-keys)
             (let* ((out (string-append (assoc-ref outputs "out")))
                    (collect2 
                      (string-append 
                        out 
                        "/lib/gcc/x86_64-linux-gnu/4.9/collect2"))
                    (ld-so
                      (string-append 
                        (assoc-ref inputs "libc")
                        ,(glibc-dynamic-linker)))
                    (guile
                      (string-append
                        (assoc-ref inputs "guile")
                        "/bin/guile")))

               ;; Hide the real "collect2" program
               (copy-file collect2 (string-append collect2 "-real"))

               ;; Write a small script to change the "-dynamic-linker"
               ;; argument before running the real "collect2".
               (with-output-to-file collect2
                 (lambda _
                   (display
                    (string-append "#!" guile " --no-auto-compile\n!#\n"))
                   (write
                    `(begin
                       (use-modules (ice-9 match))
                       (define (update-dynamic-linker args)
                         (let loop ((args args) (acc '()))
                           (match args
                             (() (reverse acc))
                             (("-dynamic-linker" _ . rest)
                              (loop rest (cons* ,ld-so "-dynamic-linker" acc)))
                             ((arg . rest)
                              (loop rest (cons arg acc))))))
                       (apply execl ,(string-append collect2 "-real")
                              (update-dynamic-linker (command-line)))))))
               #t))))))
    (inputs
     `(("guile" ,guile-2.2)))
    (native-inputs
     `(("patchelf" ,patchelf)
       ,@(map (match-lambda
                ((source name version hash)
                 `(,(string-append name ".deb")
                   ,(origin
                      (method url-fetch)
                      (uri (debian-url source name version))
                      (sha256 (base16-string->bytevector hash))))))
              %debian-gnat-closure)))
    (synopsis "GNU Ada language compiler")
    (description (string-append
                   "GNAT is a compiler for the Ada 2012 programming language."
                   "It produces optimized code on platforms supported by the GNU"
                   "Compiler Collection (GCC)."))
    (home-page "https://gnu.org/software/gnat")
    (license license:gpl3+)))

;;; GNAT commencement

(define-public (make-gnat-boot0 the-gcc)
  (package
    (inherit the-gcc)
    (name "gnat-boot0")
    (arguments
      (substitute-keyword-arguments (package-arguments the-gcc)
        ((#:configure-flags flags)
          `(cons "--enable-languages=c,c++,ada"
            (filter
              (lambda (flag)
                (not (string-prefix? "--enable-languages" flag)))
                       ,flags)))))
    (native-inputs
     `(("gcc" ,gnat-debian)
       ,@(package-native-inputs the-gcc)))))

(define (make-gnat-final the-gcc)
  (package
    (inherit (make-gnat-boot0 the-gcc))
    (name "gnat-final")
    (native-inputs
     `(("gcc" ,(make-gnat-boot0 the-gcc))
       ,@(package-native-inputs the-gcc)))))


;;; GNAT packages

(define (make-gnat the-gcc)
  (package
    (inherit the-gcc)
    (name "gnat")
    (arguments
     (substitute-keyword-arguments (package-arguments the-gcc)
       ((#:configure-flags flags)
        `(cons "--enable-languages=c,c++,ada"
               (filter (lambda (flag)
                         (not (or (string-prefix? "--enable-languages" flag)
                                  (string-prefix? "--disable-multilib" flag))))
                       (cons "--enable-multilib" ,flags))))))
    (native-inputs
     (cons `("gcc" ,(make-gnat-final the-gcc))
           (package-native-inputs the-gcc)))))

;(define-public gnat gnat-10)

(define-public gnat
  (make-gnat gcc))

(define-public gnat-toolchain
  (package
    (inherit ((@@ (gnu packages commencement) make-gcc-toolchain) gnat))
    (name "gnat-toolchain")))