;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;; SPDX-License-Identifier: GPL-3.0-or-later

(use-modules (gnu packages bootstrap)
             (gnu packages elf)
             (gnu packages guile)
             (gnu packages gcc)
             (gnu packages perl)
             (guix base16)
             (guix build-system gnu)
             (guix download)
             ((guix licenses) #:prefix license:)
             (guix packages)
             (guix utils)
             (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 gnat-debian
  (package
    (name "gnat-debian")
    (version "4.9.2-1")
    (source #f)
    (build-system gnu-build-system)
    (arguments
     `(#:tests? #f
       #:strip-binaries? #f
       #:modules ((ice-9 match)
                  ,@%gnu-build-system-modules)
       #:phases
       (modify-phases %standard-phases
         ;; Instead of a single source archive, we have a bunch of
         ;; Debian package archives to unpack.
         (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))
         ;; There is a symlink to "libgcc_s.so" that uses an absolute
         ;; path.  We need to make it 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.  We need to
         ;; patch the binaries so that they can find their shared
         ;; libraries and the dynamic linker.
         (add-after 'configure 'patch-elves
           (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)))
                    (elves (find-files "."
                                       (lambda (file stat)
                                         (and (not (string-suffix? ".o" file))
                                              (elf-file? file))))))
               (for-each (lambda (elf)
                           (format #t "Setting 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 "Setting interpreter for ~a~%" elf)
                             (invoke "patchelf" "--set-interpreter" ld-so elf)))
                         elves)
               #t)))
         (delete 'configure)
         (delete 'build)
         (replace 'install
           (lambda* (#:key outputs #:allow-other-keys)
             (let ((out (assoc-ref outputs "out")))
               (copy-recursively "usr" out)
               #t)))
         ;; Tthe 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 compiler")
    (description "GNAT is a full-featured Ada 2012 compiler.")
    (home-page "https://gcc.gnu.org/")
    (license license:gpl3+)))


;;; GNAT commencement

(define-public gnat-boot0
  (package
    (inherit gcc)
    (name "gnat-boot0")
    (arguments
     (substitute-keyword-arguments (package-arguments 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 gcc)))))

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


;;; GNAT packages

;; XXX: These packages conflict with GCC.  Ideally, they would extend
;; GCC, but that may require modifying the GCC package, which is
;; something I would like to avoid (unless it could be merged
;; upstream).  It may be possible to wrap `gcc' and use its `-B' flag
;; to find the Ada compiler.  Another option could be to make a union
;; package.

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

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

(define-public gnat gnat-5)

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