code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018, 2019 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018, 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu packages make-bootstrap)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix memoization)
  #:use-module ((guix licenses) #:select (gpl3+))
  #:use-module (guix build-system trivial)
  #:use-module (guix build-system gnu)
  #:use-module ((gnu packages) #:select (search-patch))
  #:use-module (gnu packages base)
  #:use-module (gnu packages cross-base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages gcc)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages bdw-gc)
  #:use-module (gnu packages libunistring)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages hurd)
  #:use-module (gnu packages mes)
  #:use-module (gnu packages multiprecision)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (%bootstrap-binaries-tarball
            %linux-libre-headers-bootstrap-tarball
            %binutils-bootstrap-tarball
            %glibc-bootstrap-tarball
            %gcc-bootstrap-tarball
            %guile-bootstrap-tarball
            %mescc-tools-bootstrap-tarball
            %mes-bootstrap-tarball
            %bootstrap-tarballs

            %guile-static-stripped
            %guile-3.0-static-stripped))

;;; Commentary:
;;;
;;; This module provides tools to build tarballs of the "bootstrap binaries"
;;; used in (gnu packages bootstrap).  These statically-linked binaries are
;;; taken for granted and used as the root of the whole bootstrap procedure.
;;;
;;; Code:

(define glibc-for-bootstrap
  (mlambdaq (base)
    "Return a libc deriving from BASE whose `system' and `popen' functions looks
for `sh' in $PATH, and without nscd, and with static NSS modules."
    (package
      (inherit base)
      (source (origin (inherit (package-source base))
                      (patches (cons (search-patch "glibc-bootstrap-system.patch")
                                     (origin-patches (package-source base))))))
      (arguments
       (substitute-keyword-arguments (package-arguments base)
         ((#:configure-flags flags)
          ;; Arrange so that getaddrinfo & co. do not contact the nscd,
          ;; and can use statically-linked NSS modules.
          `(cons* "--disable-nscd" "--disable-build-nscd"
                  "--enable-static-nss"
                  ,flags))))

      ;; Remove the 'debug' output to allow bit-reproducible builds (when the
      ;; 'debug' output is used, ELF files end up with a .gnu_debuglink, which
      ;; includes a CRC of the corresponding debugging symbols; those symbols
      ;; contain store file names, so the CRC changes at every rebuild.)
      (outputs (delete "debug" (package-outputs base))))))

(define gcc-for-bootstrap
  (mlambdaq (glibc)
    "Return a variant of GCC that uses the bootstrap variant of GLIBC."
    (package
      (inherit gcc-5)
      (outputs '("out")) ;all in one so libgcc_s is easily found
      (inputs
       `( ;; Distinguish the name so we can refer to it below.
         ("bootstrap-libc" ,(glibc-for-bootstrap glibc))
         ("libc:static" ,(glibc-for-bootstrap glibc) "static")
         ,@(package-inputs gcc-5))))))

(define (package-with-relocatable-glibc p)
  "Return a variant of P that uses the libc as defined by
`glibc-for-bootstrap'."

  (define (cross-bootstrap-libc target)
    (glibc-for-bootstrap
     ;; `cross-libc' already returns a cross libc, so clear
     ;; %CURRENT-TARGET-SYSTEM.
     (parameterize ((%current-target-system #f))
       (cross-libc target))))

  ;; Standard inputs with the above libc and corresponding GCC.

  (define (inputs)
    (if (%current-target-system)                ; is this package cross built?
        `(("cross-libc"
           ,(cross-bootstrap-libc (%current-target-system)))
          ("cross-libc:static"
           ,(cross-bootstrap-libc (%current-target-system))
           "static"))
        '()))

  (define (native-inputs)
    (if (%current-target-system)
        (let* ((target (%current-target-system))
               (xgcc (cross-gcc
                      target
                      #:xbinutils (cross-binutils target)
                      #:libc (cross-bootstrap-libc target))))
          `(("cross-gcc" ,(package
                            (inherit xgcc)
                            (search-paths
                             ;; Ensure the cross libc headers appears on the
                             ;; C++ system header search path.
                             (cons (search-path-specification
                                    (variable "CROSS_CPLUS_INCLUDE_PATH")
                                    (files '("include")))
                                   (package-search-paths gcc-5)))))
            ("cross-binutils" ,(cross-binutils target))
            ,@(%final-inputs)))
        `(("libc" ,(glibc-for-bootstrap glibc))
          ("libc:static" ,(glibc-for-bootstrap glibc) "static")
          ("gcc" ,(gcc-for-bootstrap glibc))
          ,@(fold alist-delete (%final-inputs) '("libc" "gcc")))))

  (package-with-explicit-inputs p inputs
                                (current-source-location)
                                #:native-inputs native-inputs))

(define %static-inputs
  ;; Packages that are to be used as %BOOTSTRAP-INPUTS.
  (let ((coreutils (package (inherit coreutils)
                      (arguments
                       `(#:configure-flags
                         '("--disable-nls"
                           "--disable-silent-rules"
                           "--enable-no-install-program=stdbuf,libstdbuf.so"
                           "CFLAGS=-Os -g0"        ; smaller, please
                           "LDFLAGS=-static -pthread"

                           ;; Work around a cross-compilation bug whereby libcoreutils.a
                           ;; would provide '__mktime_internal', which conflicts with the
                           ;; one in libc.a.
                           ,@(if (%current-target-system)
                                 `("gl_cv_func_working_mktime=yes")
                                 '()))

                         #:tests? #f   ; signal-related Gnulib tests fail
                         ,@(package-arguments coreutils)))

                      ;; Remove optional dependencies such as GMP.  Keep Perl
                      ;; except if it's missing (which is the case when
                      ;; cross-compiling).
                      (inputs (match (assoc "perl" (package-inputs coreutils))
                                (#f '())
                                (x  (list x))))

                      ;; Remove the 'debug' output (see above for the reason.)
                      (outputs '("out"))))
        (bzip2 (package (inherit bzip2)
                 (arguments
                  (substitute-keyword-arguments (package-arguments bzip2)
                    ((#:phases phases)
                     `(modify-phases ,phases
                        (add-before 'build 'dash-static
                          (lambda _
                            (substitute* "Makefile"
                              (("^LDFLAGS[[:blank:]]*=.*$")
                               "LDFLAGS = -static"))
                            #t))))))))
        (xz (package (inherit xz)
              (outputs '("out"))
              (arguments
               `(#:strip-flags '("--strip-all")
                 #:phases (modify-phases %standard-phases
                            (add-before 'configure 'static-executable
                              (lambda _
                                ;; Ask Libtool for a static executable.
                                (substitute* "src/xz/Makefile.in"
                                  (("^xz_LDADD =")
                                   "xz_LDADD = -all-static"))
                                #t)))))))
        (gawk (package (inherit gawk)
                (source (origin (inherit (package-source gawk))
                          (patches (cons (search-patch "gawk-shell.patch")
                                         (origin-patches
                                          (package-source gawk))))))
                (arguments
                 `(;; Starting from gawk 4.1.0, some of the tests for the
                   ;; plug-in mechanism just fail on static builds:
                   ;;
                   ;; ./fts.awk:1: error: can't open shared library `filefuncs' for reading (No such file or directory)
                   #:tests? #f

                   ,@(substitute-keyword-arguments (package-arguments gawk)
                       ((#:phases phases)
                        `(modify-phases ,phases
                           (add-before 'configure 'no-export-dynamic
                             (lambda _
                               ;; Since we use `-static', remove
                               ;; `-export-dynamic'.
                               (substitute* "configure"
                                 (("-Wl,-export-dynamic") ""))
                               #t)))))))
                (inputs (if (%current-target-system)
                            `(("bash" ,static-bash))
                            '()))))
	(tar (package (inherit tar)
	       (arguments
                `(;; Work around a cross-compilation bug whereby libgnu.a would provide
                  ;; '__mktime_internal', which conflicts with the one in libc.a.
                  ,@(if (%current-target-system)
                        `(#:configure-flags '("gl_cv_func_working_mktime=yes"))
                        '())
                  ,@(substitute-keyword-arguments (package-arguments tar)
                      ((#:phases phases)
                       `(modify-phases ,phases
                          (replace 'set-shell-file-name
                            (lambda _
                              ;; Do not use "/bin/sh" to run programs; see
                              ;; <http://lists.gnu.org/archive/html/guix-devel/2016-09/msg02272.html>.
                              (substitute* "src/system.c"
                                (("/bin/sh") "sh")
                                (("execv ") "execvp "))
                              #t)))))))))
        ;; We don't want to retain a reference to /gnu/store in the bootstrap
        ;; versions of egrep/fgrep, so we remove the custom phase added since
        ;; grep@2.25. The effect is 'egrep' and 'fgrep' look for 'grep' in
        ;; $PATH.
        (grep (package
                (inherit grep)
                (inputs '())                   ;remove PCRE, which is optional
                (arguments
                 (substitute-keyword-arguments (package-arguments grep)
                   ((#:phases phases)
                    `(modify-phases ,phases
                       (delete 'fix-egrep-and-fgrep)))))))
        (finalize (compose static-package
                           package-with-relocatable-glibc)))
    `(,@(map (match-lambda
              ((name package)
               (list name (finalize package))))
             `(("tar" ,tar)
               ("gzip" ,gzip)
               ("bzip2" ,bzip2)
               ("xz" ,xz)
               ("patch" ,patch)
               ("coreutils" ,coreutils)
               ("sed" ,sed)
               ("grep" ,grep)
               ("gawk" ,gawk)))
      ("bash" ,static-bash))))

(define %static-binaries
  (package
    (name "static-binaries")
    (version "0")
    (build-system trivial-build-system)
    (source #f)
    (inputs %static-inputs)
    (arguments
     `(#:modules ((guix build utils))
       #:builder
       (begin
         (use-modules (ice-9 ftw)
                      (ice-9 match)
                      (srfi srfi-1)
                      (srfi srfi-26)
                      (guix build utils))

         (let ()
          (define (directory-contents dir)
            (map (cut string-append dir "/" <>)
                 (scandir dir (negate (cut member <> '("." ".."))))))

          (define (copy-directory source destination)
            (for-each (lambda (file)
                        (format #t "copying ~s...~%" file)
                        (copy-file file
                                   (string-append destination "/"
                                                  (basename file))))
                      (directory-contents source)))

          (let* ((out (assoc-ref %outputs "out"))
                 (bin (string-append out "/bin")))
            (mkdir-p bin)

            ;; Copy Coreutils binaries.
            (let* ((coreutils (assoc-ref %build-inputs "coreutils"))
                   (source    (string-append coreutils "/bin")))
              (copy-directory source bin))

            ;; For the other inputs, copy just one binary, which has the
            ;; same name as the input.
            (for-each (match-lambda
                       ((name . dir)
                        (let ((source (string-append dir "/bin/" name)))
                          (format #t "copying ~s...~%" source)
                          (copy-file source
                                     (string-append bin "/" name)))))
                      (alist-delete "coreutils" %build-inputs))

            ;; But of course, there are exceptions to this rule.
            (let ((grep (assoc-ref %build-inputs "grep")))
              (install-file (string-append grep "/bin/fgrep") bin)
              (install-file (string-append grep "/bin/egrep") bin))

            ;; Clear references to the store path.
            (for-each remove-store-references
                      (directory-contents bin))

            (with-directory-excursion bin
              ;; Programs such as Perl's build system want these aliases.
              (symlink "bash" "sh")
              (symlink "gawk" "awk"))

            #t)))))
    (synopsis "Statically-linked bootstrap binaries")
    (description
     "Binaries used to bootstrap the distribution.")
    (license gpl3+)
    (home-page #f)))

(define %linux-libre-headers-stripped
  ;; The subset of Linux-Libre-Headers that we need.
  (package (inherit linux-libre-headers)
    (name (string-append (package-name linux-libre-headers) "-stripped"))
    (build-system trivial-build-system)
    (outputs '("out"))
    (arguments
     `(#:modules ((guix build utils)
                  (guix build make-bootstrap))
       #:builder
       (begin
         (use-modules (guix build utils)
                      (guix build make-bootstrap))

         (let* ((in  (assoc-ref %build-inputs "linux-libre-headers"))
                (out (assoc-ref %outputs "out")))
           (copy-linux-headers out in)
           #t))))
    (inputs `(("linux-libre-headers" ,linux-libre-headers)))))

(define %binutils-static
  ;; Statically-linked Binutils.
  (package (inherit binutils)
    (name "binutils-static")
    (arguments
     `(#:configure-flags (cons "--disable-gold"
                               ,(match (memq #:configure-flags
                                             (package-arguments binutils))
                                  ((#:configure-flags flags _ ...)
                                   flags)))
       #:strip-flags '("--strip-all")
       #:phases (modify-phases %standard-phases
                  (add-before 'configure 'all-static
                    (lambda _
                      ;; The `-all-static' libtool flag can only be passed
                      ;; after `configure', since configure tests don't use
                      ;; libtool, and only for executables built with libtool.
                      (substitute* '("binutils/Makefile.in"
                                     "gas/Makefile.in"
                                     "ld/Makefile.in")
                        (("^LDFLAGS =(.*)$" line)
                         (string-append line
                                        "\nAM_LDFLAGS = -static -all-static\n")))
                      #t)))))))

(define %binutils-static-stripped
  ;; The subset of Binutils that we need.
  (package (inherit %binutils-static)
    (name (string-append (package-name %binutils-static) "-stripped"))
    (build-system trivial-build-system)
    (outputs '("out"))
    (arguments
     `(#:modules ((guix build utils))
       #:builder
       (begin
         (use-modules (guix build utils))

         (setvbuf (current-output-port)
                  (cond-expand (guile-2.0 _IOLBF) (else 'line)))
         (let* ((in  (assoc-ref %build-inputs "binutils"))
                (out (assoc-ref %outputs "out"))
                (bin (string-append out "/bin")))
           (mkdir-p bin)
           (for-each (lambda (file)
                       (let ((target (string-append bin "/" file)))
                         (format #t "copying `~a'...~%" file)
                         (copy-file (string-append in "/bin/" file)
                                    target)
                         (remove-store-references target)))
                     '("ar" "as" "ld" "nm"  "objcopy" "objdump"
                       "ranlib" "readelf" "size" "strings" "strip"))
           #t))))
    (inputs `(("binutils" ,%binutils-static)))))

(define (%glibc-stripped)
  ;; GNU libc's essential shared libraries, dynamic linker, and headers,
  ;; with all references to store directories stripped.  As a result,
  ;; libc.so is unusable and need to be patched for proper relocation.
  (let ((glibc (glibc-for-bootstrap glibc)))
    (package (inherit glibc)
      (name "glibc-stripped")
      (build-system trivial-build-system)
      (arguments
       `(#:modules ((guix build utils)
                    (guix build make-bootstrap))
         #:builder
         (begin
           (use-modules (guix build make-bootstrap))
           (make-stripped-libc (assoc-ref %outputs "out")
                               (assoc-ref %build-inputs "libc")
                               (assoc-ref %build-inputs "kernel-headers")))))
      (inputs `(("kernel-headers"
                 ,(if (or (and (%current-target-system)
                               (hurd-triplet? (%current-target-system)))
                          (string-suffix? "-hurd" (%current-system)))
                      gnumach-headers
                      linux-libre-headers))
                ("libc" ,(let ((target (%current-target-system)))
                           (if target
                               (glibc-for-bootstrap
                                (parameterize ((%current-target-system #f))
                                  (cross-libc target)))
                               glibc)))))
      (native-inputs '())
      (propagated-inputs '())

      ;; Only one output.
      (outputs '("out")))))

(define %gcc-static
  ;; A statically-linked GCC, with stripped-down functionality.
  (package-with-relocatable-glibc
   (package (inherit gcc-5)
     (name "gcc-static")
     (outputs '("out"))                           ; all in one
     (arguments
      (substitute-keyword-arguments (package-arguments gcc-5)
        ((#:modules modules %gnu-build-system-modules)
         `((srfi srfi-1)
           (srfi srfi-26)
           (ice-9 regex)
           ,@modules))
        ((#:guile _) #f)
        ((#:implicit-inputs? _) #t)
        ((#:configure-flags flags)
         `(append (list
                   ;; We don't need a full bootstrap here.
                   "--disable-bootstrap"

                   ;; Make sure '-static' is passed where it matters.
                   "--with-stage1-ldflags=-static"

                   ;; GCC 4.8+ requires a C++ compiler and library.
                   "--enable-languages=c,c++"

                   ;; Make sure gcc-nm doesn't require liblto_plugin.so.
                   "--disable-lto"

                   "--disable-shared"
                   "--disable-plugin"
                   "--disable-libmudflap"
                   "--disable-libatomic"
                   "--disable-libsanitizer"
                   "--disable-libitm"
                   "--disable-libgomp"
                   "--disable-libcilkrts"
                   "--disable-libvtv"
                   "--disable-libssp"
                   "--disable-libquadmath")
                  (remove (cut string-match "--(.*plugin|enable-languages)" <>)
                          ,flags)))
        ((#:phases phases)
         `(modify-phases ,phases
            (add-after 'pre-configure 'remove-lgcc_s
              (lambda _
                ;; Remove the '-lgcc_s' added to GNU_USER_TARGET_LIB_SPEC in
                ;; the 'pre-configure phase of our main gcc package, because
                ;; that shared library is not present in this static gcc.  See
                ;; <https://lists.gnu.org/archive/html/guix-devel/2015-01/msg00008.html>.
                (substitute* (cons "gcc/config/rs6000/sysv4.h"
                                   (find-files "gcc/config"
                                               "^gnu-user.*\\.h$"))
                  ((" -lgcc_s}}") "}}"))
                #t))))))
     (inputs
      `(("zlib:static" ,zlib "static")
        ("isl:static" ,isl-0.18 "static")
        ,@(package-inputs gcc-5)))
     (native-inputs
      (if (%current-target-system)
          `(;; When doing a Canadian cross, we need GMP/MPFR/MPC both
            ;; as target inputs and as native inputs; the latter is
            ;; needed when building build-time tools ('genconstants',
            ;; etc.)  Failing to do that leads to misdetections of
            ;; declarations by 'gcc/configure', and eventually to
            ;; duplicate declarations as reported in
            ;; <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=59217>.
            ("gmp-native" ,gmp)
            ("mpfr-native" ,mpfr)
            ("mpc-native" ,mpc)
            ,@(package-native-inputs gcc-5))
          (package-native-inputs gcc-5))))))

(define %gcc-stripped
  ;; The subset of GCC files needed for bootstrap.
  (package (inherit gcc-5)
    (name "gcc-stripped")
    (build-system trivial-build-system)
    (source #f)
    (outputs '("out"))                            ;only one output
    (arguments
     `(#:modules ((guix build utils))
       #:builder
       (begin
         (use-modules (srfi srfi-1)
                      (srfi srfi-26)
                      (guix build utils))

         (setvbuf (current-output-port)
                  (cond-expand (guile-2.0 _IOLBF) (else 'line)))
         (let* ((out        (assoc-ref %outputs "out"))
                (bindir     (string-append out "/bin"))
                (libdir     (string-append out "/lib"))
                (includedir (string-append out "/include"))
                (libexecdir (string-append out "/libexec"))
                (gcc        (assoc-ref %build-inputs "gcc")))
           (copy-recursively (string-append gcc "/bin") bindir)
           (for-each remove-store-references
                     (find-files bindir ".*"))

           (copy-recursively (string-append gcc "/lib") libdir)
           (for-each remove-store-references
                     (remove (cut string-suffix? ".h" <>)
                             (find-files libdir ".*")))

           (copy-recursively (string-append gcc "/libexec")
                             libexecdir)
           (for-each remove-store-references
                     (find-files libexecdir ".*"))

           ;; Starting from GCC 4.8, helper programs built natively
           ;; (‘genchecksum’, ‘gcc-nm’, etc.) rely on C++ headers.
           (copy-recursively (string-append gcc "/include/c++")
                             (string-append includedir "/c++"))

           ;; For native builds, check whether the binaries actually work.
           ,@(if (%current-target-system)
                 '()
                 '((for-each (lambda (prog)
                               (invoke (string-append gcc "/bin/" prog)
                                       "--version"))
                             '("gcc" "g++" "cpp"))))

           #t))))
    (inputs `(("gcc" ,%gcc-static)))))

;; Two packages: first build static, bare minimum content.
(define %mescc-tools-static
  ;; A statically linked MesCC Tools.
  (package
    (inherit mescc-tools-0.5.2)
    (name "mescc-tools-static")
    (arguments
     `(#:system "i686-linux"
       ,@(substitute-keyword-arguments (package-arguments mescc-tools)
           ((#:make-flags flags)
            `(cons "CC=gcc -static" ,flags)))))))

;; ... next remove store references.
(define %mescc-tools-static-stripped
  ;; A statically linked Mescc Tools with store references removed, for
  ;; bootstrap.
  (package
    (inherit %mescc-tools-static)
    (name (string-append (package-name %mescc-tools-static) "-stripped"))
    (build-system trivial-build-system)
    (arguments
     `(#:modules ((guix build utils))
       #:builder
       (begin
         (use-modules (guix build utils))
         (let* ((in  (assoc-ref %build-inputs "mescc-tools"))
                (out (assoc-ref %outputs "out"))
                (bin (string-append out "/bin")))
           (mkdir-p bin)
           (for-each (lambda (file)
                       (let ((target (string-append bin "/" file)))
                         (format #t "copying `~a'...~%" file)
                         (copy-file (string-append in "/bin/" file)
                                    target)
                         (remove-store-references target)))
                     '( "M1" "blood-elf" "hex2"))
           #t))))
    (inputs `(("mescc-tools" ,%mescc-tools-static)))))

;; Two packages: first build static, bare minimum content.
(define-public %mes-minimal
  ;; A minimal Mes without documentation.
  (let ((triplet "i686-unknown-linux-gnu"))
    (package
      (inherit mes-0.19)
      (name "mes-minimal")
      (native-inputs
       `(("guile" ,guile-2.2)))
      (arguments
       `(#:system "i686-linux"
         #:strip-binaries? #f
         #:configure-flags '("--mes")
         #:phases
         (modify-phases %standard-phases
           (delete 'patch-shebangs)
           (add-after 'install 'strip-install
             (lambda _
               (let* ((out (assoc-ref %outputs "out"))
                      (share (string-append out "/share")))
                 (delete-file-recursively (string-append out "/lib/guile"))
                 (delete-file-recursively (string-append share "/guile"))
                 (delete-file-recursively (string-append share "/mes/scaffold"))

                 (for-each delete-file
                           (find-files
                            (string-append share "/mes/lib")
                            "\\.(h|c)")))))))))))

;; next remove store references.
(define %mes-minimal-stripped
  ;; A minimal Mes with store references removed, for bootstrap.
  (package
    (inherit %mes-minimal)
    (name (string-append (package-name %mes-minimal) "-stripped"))
    (build-system trivial-build-system)
    (arguments
     `(#:modules ((guix build utils))
       #:builder
       (begin
         (use-modules (guix build utils))
         (let ((in  (assoc-ref %build-inputs "mes"))
               (out (assoc-ref %outputs "out")))

           (copy-recursively in out)
           (for-each (lambda (dir)
                       (for-each remove-store-references
                                 (find-files (string-append out "/" dir)
                                             ".*")))
                     '("bin" "share/mes"))
           #t))))
    (inputs `(("mes" ,%mes-minimal)))))

(define* (make-guile-static guile patches)
  (package-with-relocatable-glibc
   (static-package
    (package
      (inherit guile)
      (source
       (origin (inherit (package-source guile))
               (patches (append (map search-patch patches)
                                (origin-patches (package-source guile))))))
      (name (string-append (package-name guile) "-static"))
      (synopsis "Statically-linked and relocatable Guile")

      ;; Remove the 'debug' output (see above for the reason.)
      (outputs (delete "debug" (package-outputs guile)))

      (inputs
       `(("libunistring:static" ,libunistring "static")
         ,@(package-inputs guile)))

      (propagated-inputs
       `(("bdw-gc" ,libgc/static-libs)
         ,@(alist-delete "bdw-gc"
                         (package-propagated-inputs guile))))
      (arguments
       (substitute-keyword-arguments (package-arguments guile)
         ((#:configure-flags flags '())
          ;; When `configure' checks for ltdl availability, it
          ;; doesn't try to link using libtool, and thus fails
          ;; because of a missing -ldl.  Work around that.

          ;; XXX: On ARMv7, disable JIT: it causes crashes with 3.0.2,
          ;; possibly related to <https://bugs.gnu.org/40737>.
          (if (target-arm32?)
              ''("LDFLAGS=-ldl" "--disable-jit")
              ''("LDFLAGS=-ldl")))
         ((#:phases phases '%standard-phases)
          `(modify-phases ,phases

             ;; Do not record the absolute file name of 'sh' in
             ;; (ice-9 popen).  This makes 'open-pipe' unusable in
             ;; a build chroot ('open-pipe*' is fine) but avoids
             ;; keeping a reference to Bash.
             (delete 'pre-configure)

             (add-before 'configure 'static-guile
               (lambda _
                 (substitute* "libguile/Makefile.in"
                   ;; Create a statically-linked `guile'
                   ;; executable.
                   (("^guile_LDFLAGS =")
                    "guile_LDFLAGS = -all-static")

                   ;; Add `-ldl' *after* libguile-2.0.la.
                   (("^guile_LDADD =(.*)$" _ ldadd)
                    (string-append "guile_LDADD = "
                                   (string-trim-right ldadd)
                                   " -ldl\n")))))))
         ((#:tests? _ #f)
          ;; There are uses of `dynamic-link' in
          ;; {foreign,coverage}.test that don't fly here.
          #f)
         ((#:parallel-build? _ #f)
          ;; Work around the fact that the Guile build system is
          ;; not deterministic when parallel-build is enabled.
          #f)))))))

(define %guile-static
  ;; A statically-linked Guile that is relocatable--i.e., it can search
  ;; .scm and .go files relative to its installation directory, rather
  ;; than in hard-coded configure-time paths.
  (make-guile-static guile-2.0 '("guile-relocatable.patch"
                                 "guile-default-utf8.patch"
                                 "guile-linux-syscalls.patch")))

(define* (make-guile-static-stripped static-guile)
  (package
    (inherit static-guile)
    (name (string-append (package-name static-guile) "-stripped"))
    (build-system trivial-build-system)
    (arguments
     ;; The end result should depend on nothing but itself.
     `(#:allowed-references ("out")
       #:modules ((guix build utils))
       #:builder
       (let ((version ,(version-major+minor (package-version static-guile))))
         (use-modules (guix build utils))

         (let* ((in     (assoc-ref %build-inputs "guile"))
                (out    (assoc-ref %outputs "out"))
                (guile1 (string-append in "/bin/guile"))
                (guile2 (string-append out "/bin/guile")))
           (mkdir-p (string-append out "/share/guile/" version))
           (copy-recursively (string-append in "/share/guile/" version)
                             (string-append out "/share/guile/" version))

           (mkdir-p (string-append out "/lib/guile/" version "/ccache"))
           (copy-recursively (string-append in "/lib/guile/" version "/ccache")
                             (string-append out "/lib/guile/" version "/ccache"))

           (mkdir (string-append out "/bin"))
           (copy-file guile1 guile2)

           ;; Verify that the relocated Guile works.
           ,@(if (%current-target-system)
                 '()
                 '((invoke guile2 "--version")))

           ;; Strip store references.
           (remove-store-references guile2)

           ;; Verify that the stripped Guile works.  If it aborts, it could be
           ;; that it tries to open iconv descriptors and fails because libc's
           ;; iconv data isn't available (see `guile-default-utf8.patch'.)
           ,@(if (%current-target-system)
                 '()
                 '((invoke guile2 "--version")))

           #t))))
    (inputs `(("guile" ,static-guile)))
    (outputs '("out"))
    (synopsis "Minimal statically-linked and relocatable Guile")))

(define %guile-static-stripped
  ;; A stripped static Guile binary, for use during bootstrap.
  (make-guile-static-stripped %guile-static))

(define %guile-3.0-static-stripped
  ;; A stripped static Guile 3.0 binary, for use in initrds.
  (make-guile-static-stripped
   (make-guile-static guile-3.0
                      '("guile-2.2-default-utf8.patch"
                        "guile-3.0-linux-syscalls.patch"
                        "guile-3.0-relocatable.patch"))))

(define (tarball-package pkg)
  "Return a package containing a tarball of PKG."
  (package (inherit pkg)
    (name (string-append (package-name pkg) "-tarball"))
    (build-system trivial-build-system)
    (native-inputs `(("tar" ,tar)
                     ("xz" ,xz)))
    (inputs `(("input" ,pkg)))
    (arguments
     (let ((name    (package-name pkg))
           (version (package-version pkg)))
       `(#:modules ((guix build utils))
         #:builder
         (begin
           (use-modules (guix build utils))
           (let ((out   (assoc-ref %outputs "out"))
                 (input (assoc-ref %build-inputs "input"))
                 (tar   (assoc-ref %build-inputs "tar"))
                 (xz    (assoc-ref %build-inputs "xz")))
             (mkdir out)
             (set-path-environment-variable "PATH" '("bin") (list tar xz))
             (with-directory-excursion input
               (invoke "tar" "cJvf"
                       (string-append out "/"
                                      ,name "-" ,version
                                      "-"
                                      ,(or (%current-target-system)
                                           (%current-system))
                                      ".tar.xz")
                       "."
                       ;; avoid non-determinism in the archive
                       "--sort=name" "--mtime=@0"
                       "--owner=root:0" "--group=root:0")))))))))

(define %bootstrap-binaries-tarball
  ;; A tarball with the statically-linked bootstrap binaries.
  (tarball-package %static-binaries))

(define %linux-libre-headers-bootstrap-tarball
  ;; A tarball with the statically-linked Linux-Libre-Headers programs.
  (tarball-package %linux-libre-headers-stripped))

(define %binutils-bootstrap-tarball
  ;; A tarball with the statically-linked Binutils programs.
  (tarball-package %binutils-static-stripped))

(define (%glibc-bootstrap-tarball)
  ;; A tarball with GNU libc's shared libraries, dynamic linker, and headers.
  (tarball-package (%glibc-stripped)))

(define %gcc-bootstrap-tarball
  ;; A tarball with a dynamic-linked GCC and its headers.
  (tarball-package %gcc-stripped))

(define %guile-bootstrap-tarball
  ;; A tarball with the statically-linked, relocatable Guile.
  (tarball-package %guile-static-stripped))

(define %mescc-tools-bootstrap-tarball
  ;; A tarball with statically-linked MesCC binary seed.
  (tarball-package %mescc-tools-static-stripped))

(define %mes-bootstrap-tarball
  ;; A tarball with Mes binary seed.
  (tarball-package %mes-minimal-stripped))

(define %bootstrap-tarballs
  ;; A single derivation containing all the bootstrap tarballs, for
  ;; convenience.
  (package
    (name "bootstrap-tarballs")
    (version "0")
    (source #f)
    (build-system trivial-build-system)
    (arguments
     `(#:modules ((guix build utils))
       #:builder
       (let ((out (assoc-ref %outputs "out")))
         (use-modules (guix build utils)
                      (ice-9 match)
                      (srfi srfi-26))

         (setvbuf (current-output-port)
                  (cond-expand (guile-2.0 _IOLBF) (else 'line)))
         (mkdir out)
         (chdir out)
         (for-each (match-lambda
                    ((name . directory)
                     (for-each (lambda (file)
                                 (format #t "~a -> ~a~%" file out)
                                 (symlink file (basename file)))
                               (find-files directory "\\.tar\\."))))
                   %build-inputs)
         #t)))
    (inputs `(("guile-tarball" ,%guile-bootstrap-tarball)
              ,@(match (or (%current-target-system) (%current-system))
                  ((or "i686-linux" "x86_64-linux")
                   `(("bootstrap-mescc-tools" ,%mescc-tools-bootstrap-tarball)
                     ("bootstrap-mes" ,%mes-bootstrap-tarball)
                     ("bootstrap-linux-libre-headers"
                      ,%linux-libre-headers-bootstrap-tarball)))
                  (_ `(("gcc-tarball" ,%gcc-bootstrap-tarball)
                       ("binutils-tarball" ,%binutils-bootstrap-tarball)
                       ("glibc-tarball" ,(%glibc-bootstrap-tarball))
                       ("coreutils&co-tarball" ,%bootstrap-binaries-tarball))))))
    (synopsis "Tarballs containing all the bootstrap binaries")
    (description synopsis)
    (home-page #f)
    (license gpl3+)))

;;; make-bootstrap.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 David Thompson <dthompson2@worcester.edu>
;;; Copyright © 2015, 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015, 2016, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2018, 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018, 2019 Rutger Helling <rhelling@mykolab.com>
;;; Copyright © 2018, 2019 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020 Vincent Legoll <vincent.legoll@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu packages man)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix git-download)
  #:use-module (guix download)
  #:use-module (guix packages)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system ruby)
  #:use-module (gnu packages dbm)
  #:use-module (gnu packages flex)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages groff)
  #:use-module (gnu packages less)
  #:use-module (gnu packages perl)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages xml))

(define-public xmltoman
  (package
    (name "xmltoman")
    (version "0.4")
    (source
     (origin
       (method url-fetch)
       (uri
        (string-append "https://sourceforge.net/projects/xmltoman/files/"
                       "xmltoman/xmltoman-" version ".tar.gz/xmltoman-"
                       version ".tar.gz/download"))
       (sha256
        (base32 "1c0lvzr7kdy63wbn1jv6s126ds7add3pxqb0vlxd3v5a2sir91wl"))))
    (build-system gnu-build-system)
    (arguments
     `(#:tests? #f                      ; No tests
       #:make-flags
       (list
        (string-append "PREFIX="
                       (assoc-ref %outputs "out")))
       #:phases
       (modify-phases %standard-phases
         (delete 'configure))))
    (propagated-inputs
     `(("perl" ,perl)
       ("perl-xml-parser" ,perl-xml-parser)))
    (synopsis "XML to Man converter")
    (description "XMLtoMan and XMLMantoHTML are two small scripts to convert xml
to man pages in groff format or html.  It features the usual man page items such
as description, options, see also, etc.")
    (home-page "http://xmltoman.sourceforge.net/")
    (license license:gpl2+)))

(define-public ronn
  (package
    (name "ronn")
    (version "0.7.3")
    (source
     (origin
       (method git-fetch)
       (uri
        (git-reference
         (url "https://github.com/rtomayko/ronn.git")
         (commit version)))
       (file-name
        (git-file-name name version))
       (sha256
        (base32 "0fkniz7j1jp8v3i05m6hks3nsh6rzvjfi0ichpi7h4gwk5byxb94"))))
    (build-system ruby-build-system)
    (arguments
     `(#:tests? #f))                   ; Library hpricot not available
    (synopsis "Manual authoring tool")
    (description "Ronn builds manuals.  It converts simple, human readable
textfiles to roff for terminal display, and also to HTML for the web.")
    (home-page "https://rtomayko.github.io/ronn/")
    (license license:expat)))

(define-public libpipeline
  (package
    (name "libpipeline")
    (version "1.5.3")
    (source (origin
              (method url-fetch)
              (uri (string-append
                    "mirror://savannah/libpipeline/libpipeline-"
                    version ".tar.gz"))
              (sha256
               (base32
                "1c5dl017xil2ssb6a5vg927bnsbc9vymfgi9ahvqbb8gypx0igsx"))))
    (build-system gnu-build-system)
    (home-page "http://libpipeline.nongnu.org/")
    (synopsis "C library for manipulating pipelines of subprocesses")
    (description
     "libpipeline is a C library for manipulating pipelines of subprocesses in
a flexible and convenient way.")
    (license license:gpl3+)))

(define-public man-db
  (package
    (name "man-db")
    (version "2.9.3")
    (source (origin
              (method url-fetch)
              (uri (string-append "mirror://savannah/man-db/man-db-"
                                  version ".tar.xz"))
              (sha256
               (base32
                "1f4palf5bdyf3f8sa0981cqxn9cjcr2pz53ngrrsybb9n0da2nps"))))
    (build-system gnu-build-system)
    (arguments
     `(#:phases
       (modify-phases %standard-phases
         (add-after 'patch-source-shebangs 'patch-test-shebangs
           (lambda* (#:key outputs #:allow-other-keys)
             ;; Patch shebangs in test scripts.
             (let ((out (assoc-ref outputs "out")))
               (for-each (lambda (file)
                           (substitute* file
                             (("#! /bin/sh")
                              (string-append "#!" (which "sh")))))
                         (remove file-is-directory?
                                 (find-files "src/tests" ".*")))
               #t)))
         (add-after 'unpack 'patch-absolute-paths
           (lambda* (#:key inputs #:allow-other-keys)
             (substitute* "src/man.c"
               (("\"iconv\"")
                (string-append "\"" (which "iconv") "\"")))
             ;; Embed an absolute reference to "preconv", otherwise it
             ;; falls back to searching in PATH and ultimately fails
             ;; to render unicode data (see <https://bugs.gnu.org/30785>).
             (substitute* "lib/encodings.c"
               (("groff_preconv = NULL")
                (string-append "groff_preconv = \""
                               (assoc-ref inputs "groff-minimal")
                               "/bin/preconv\"")))
             #t)))
       #:configure-flags
       (let ((groff (assoc-ref %build-inputs "groff"))
             (groff-minimal (assoc-ref %build-inputs "groff-minimal"))
             (less  (assoc-ref %build-inputs "less"))
             (gzip  (assoc-ref %build-inputs "gzip"))
             (bzip2 (assoc-ref %build-inputs "bzip2"))
             (xz    (assoc-ref %build-inputs "xz"))
             (util  (assoc-ref %build-inputs "util-linux")))
         ;; Invoke groff, less, gzip, bzip2, and xz directly from the store.
         (append (list ;; Disable setuid man user.
                       "--disable-setuid"
                       ;; Don't constrain ownership of system-wide cache files.
                       ;; Otherwise creating the manpage database fails with
                       ;; man-db > 2.7.5.
                       "--disable-cache-owner"
                       (string-append "--with-pager=" less "/bin/less")
                       (string-append "--with-gzip=" gzip "/bin/gzip")
                       (string-append "--with-bzip2=" bzip2 "/bin/gzip")
                       (string-append "--with-xz=" xz "/bin/xz")
                       (string-append "--with-col=" util "/bin/col")
                       ;; The default systemd directories ignore --prefix.
                       (string-append "--with-systemdsystemunitdir="
                                      %output "/lib/systemd/system")
                       (string-append "--with-systemdtmpfilesdir="
                                      %output "/lib/tmpfiles.d"))
                 (map (lambda (prog)
                        (string-append "--with-" prog "=" groff-minimal
                                       "/bin/" prog))
                      '("nroff" "eqn" "neqn" "tbl" "refer" "pic"))))

       ;; At run time we should refer to GROFF-MINIMAL, not GROFF (the latter
       ;; pulls in Perl.)
       #:disallowed-references (,groff)

       #:modules ((guix build gnu-build-system)
                  (guix build utils)
                  (srfi srfi-1))))
    (native-inputs
     `(("pkg-config" ,pkg-config)
       ("flex" ,flex)
       ("groff" ,groff)))   ;needed at build time (troff, grops, soelim, etc.)
    (inputs
     `(("gdbm" ,gdbm)
       ("groff-minimal" ,groff-minimal)
       ("less" ,less)
       ("libpipeline" ,libpipeline)
       ;; FIXME: 4.8 and later can use libseccomp, but it causes test
       ;; failures in the build chroot.
       ;;("libseccomp" ,libseccomp)
       ("util-linux" ,util-linux)))
    (native-search-paths
     (list (search-path-specification
            (variable "MANPATH")
            (files '("share/man")))))
    (home-page "http://man-db.nongnu.org/")
    (synopsis "Standard Unix documentation system")
    (description
     "Man-db is an implementation of the standard Unix documentation system
accessed using the man command.  It uses a Berkeley DB database in place of
the traditional flat-text whatis databases.")
    (license license:gpl2+)))

(define-public man-pages
  (package
    (name "man-pages")
    (version "5.08")
    (source
     (origin
       (method url-fetch)
       (uri
        (list (string-append "mirror://kernel.org/linux/docs/man-pages/"
                             "man-pages-" version ".tar.xz")
              (string-append "mirror://kernel.org/linux/docs/man-pages/Archive/"
                             "man-pages-" version ".tar.xz")))
       (sha256
        (base32 "1xzp3f6wvw3wplk1a1x09zfv0jp0pdc9wh95czndh3h8z0qwv9yf"))))
    (build-system gnu-build-system)
    (arguments
     '(#:phases (modify-phases %standard-phases (delete 'configure))

       ;; The 'all' target depends on three targets that directly populate
       ;; $(MANDIR) based on its current contents.  Doing that in parallel
       ;; leads to undefined behavior (see <http://bugs.gnu.org/18701>.)
       #:parallel-build? #f

       #:tests? #f
       #:make-flags (list (string-append "MANDIR="
                                         (assoc-ref %outputs "out")
                                         "/share/man"))))
    (home-page "https://www.kernel.org/doc/man-pages/")
    (synopsis "Development manual pages from the Linux project")
    (description
     "This package provides traditional Unix \"man pages\" documenting the
Linux kernel and C library interfaces employed by user-space programs.")

    ;; Each man page has its own license; some are GPLv2+, some are MIT/X11.
    (license license:gpl2+)))

(define-public help2man
  (package
    (name "help2man")
    (version "1.47.13")
    (source
     (origin
      (method url-fetch)
      (uri (string-append "mirror://gnu/help2man/help2man-"
                          version ".tar.xz"))
      (sha256
       (base32
        "08q5arxz4j4pyx5q4712c2rn7p7dw7as9xg38yvmsh1c3ynvpy5p"))))
    (build-system gnu-build-system)
    (arguments `(;; There's no `check' target.
                 #:tests? #f))
    (inputs
     `(("perl" ,perl)
       ;; TODO: Add these optional dependencies.
       ;; ("perl-LocaleGettext" ,perl-LocaleGettext)
       ;; ("gettext" ,gettext-minimal)
       ))
    (native-inputs
     `(("perl" ,perl)))
    (home-page "https://www.gnu.org/software/help2man/")
    (synopsis "Automatically generate man pages from program --help")
    (description
     "GNU help2man is a program that converts the output of standard
\"--help\" and \"--version\" command-line arguments into a manual page
automatically.")
    (license license:gpl3+)))

(define-public scdoc
  (package
   (name "scdoc")
   (version "1.10.1")
   (source
    (origin
     (method url-fetch)
     (uri (string-append "https://git.sr.ht/%7Esircmpwn/scdoc/archive/" version
                         ".tar.gz"))
     (file-name (string-append name "-" version ".tar.gz"))
     (sha256
      (base32
       "13x7g1r56bshvfmlvapvz35ywnbgsh337kywb5kcv8nc6b3j3q40"))))
   (build-system gnu-build-system)
   (arguments
    `(#:make-flags
      (list "CC=gcc" (string-append "PREFIX=" (assoc-ref %outputs "out")))
      #:phases
      (modify-phases %standard-phases
        (delete 'configure))))
   (home-page "https://git.sr.ht/~sircmpwn/scdoc")
   (synopsis "Simple man page generator")
   (description "scdoc is a simple man page generator written for POSIX systems
in C99.")
   ;; MIT license, see /share/doc/scdoc-1.6.0/COPYING.
   (license license:expat)))

(define-public txt2man
  (package
    (name "txt2man")
    (version "1.6.0")
    (source
     (origin
       (method git-fetch)
       (uri (git-reference
              (url "https://github.com/mvertes/txt2man")
              (commit (string-append "txt2man-" version))))
       (file-name (git-file-name name version))
       (sha256
        (base32
         "1razjpvlcp85hqli77mwr9nmn5jnv3lm1fxbbqjpx1brv3h1lvm5"))))
    (build-system gnu-build-system)
    (arguments
     `(#:tests? #f ; no "check" target
       #:make-flags (list (string-append "prefix=" (assoc-ref %outputs "out")))
       #:phases (modify-phases %standard-phases (delete 'configure))))
    (inputs
     `(("gawk" ,gawk)))
    (home-page "https://github.com/mvertes/txt2man")
    (synopsis "Convert text to man page")
    (description "Txt2man converts flat ASCII text to man page format.")
    (license license:gpl2+)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Nikita <nikita@n0.is>
;;; Copyright © 2017, 2018, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu packages markup)
  #:use-module (guix licenses)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module (guix packages)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system trivial)
  #:use-module (guix build-system cmake)
  #:use-module (guix build-system perl)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages)
  #:use-module (gnu packages perl)
  #:use-module (gnu packages python)
  #:use-module (gnu packages web))

(define-public hoedown
  (package
    (name "hoedown")
    (version "3.0.7")
    (source (origin
             (method git-fetch)
             (uri (git-reference
                    (url "https://github.com/hoedown/hoedown")
                    (commit version)))
             (file-name (git-file-name name version))
             (sha256
              (base32
               "1kr3hxjg2dgmwy9738qgj3sh3f5cygx0zxskkfhrg7x19bq9yd26"))))
    (build-system gnu-build-system)
    (arguments
     '(#:make-flags (list "CC=gcc" (string-append "PREFIX=" %output))
       #:phases (modify-phases %standard-phases
                  (delete 'configure)) ; no configure script
       #:test-target "test"))
    (native-inputs
     `(("python" ,python-2)
       ("tidy" ,tidy)))
    (synopsis "Markdown processing library")
    (description "Hoedown is a standards compliant, fast, secure markdown
processing library written in C.")
    (home-page "https://github.com/hoedown/hoedown")
    (license expat)))

(define-public markdown
  (package
    (name "markdown")
    (version "1.0.1")
    (source
     (origin
       (method url-fetch)
       (uri (string-append
             "http://daringfireball.net/projects/downloads/"
             (string-capitalize name) "_" version ".zip"))
       (sha256
        (base32 "0dq1pj91pvlwkv0jwcgdfpv6gvnxzrk3s8mnh7imamcclnvfj835"))))
    (build-system trivial-build-system)
    (arguments
     '(#:modules ((guix build utils))
       #:builder
       (begin
         (use-modules (guix build utils))
         (let ((source (assoc-ref %build-inputs "source"))
               (out    (assoc-ref %outputs "out"))
               (perlbd (string-append (assoc-ref %build-inputs "perl") "/bin"))
               (unzip  (string-append (assoc-ref %build-inputs "unzip")
                                      "/bin/unzip")))
           (mkdir-p out)
           (with-directory-excursion out
             (invoke unzip source)
             (mkdir "bin")
             (mkdir-p "share/doc")
             (rename-file "Markdown_1.0.1/Markdown.pl" "bin/markdown")
             (rename-file "Markdown_1.0.1/Markdown Readme.text"
                          "share/doc/README")
             (patch-shebang "bin/markdown" (list perlbd))
             (delete-file-recursively "Markdown_1.0.1"))
           #t))))
    (native-inputs `(("unzip" ,unzip)))
    (inputs `(("perl" ,perl)))
    (home-page "http://daringfireball.net/projects/markdown")
    (synopsis "Text-to-HTML conversion tool")
    (description
     "Markdown is a text-to-HTML conversion tool for web writers.  It allows
you to write using an easy-to-read, easy-to-write plain text format, then
convert it to structurally valid XHTML (or HTML).")
    (license (non-copyleft "file://License.text"
                           "See License.text in the distribution."))))

(define-public discount
  (package
    (name "discount")
    (version "2.2.4")
    (source (origin
             (method url-fetch)
             (uri (string-append
                   "http://www.pell.portland.or.us/~orc/Code/"
                   "discount/discount-" version ".tar.bz2"))
             (sha256
              (base32
               "199hwajpspqil0a4y3yxsmhdp2dm73gqkzfk4mrwzsmlq8y1xzbl"))))
    (build-system gnu-build-system)
    (arguments
     `(#:test-target "test"
       #:make-flags (list
                     (string-append "LFLAGS=-L. -Wl,-rpath="
                                    (assoc-ref %outputs "out") "/lib"))
       #:phases
       (modify-phases %standard-phases
         (add-before 'configure 'set-AC_PATH
           (lambda _
             ;; The default value is not suitable, so override using an
             ;; environment variable. This just affects the build, and not the
             ;; resulting store item.
             (setenv "AC_PATH" (getenv "PATH"))
             #t))
         (replace 'configure
           (lambda* (#:key inputs outputs #:allow-other-keys)
             (setenv "CC" "gcc")
             (invoke "./configure.sh"
                     (string-append "--prefix=" (assoc-ref outputs "out"))
                     "--shared"))))))
    (synopsis "Markdown processing library, written in C")
    (description
     "Discount is a markdown implementation, written in C.  It provides a
@command{markdown} command, and a library.")
    (home-page "https://www.pell.portland.or.us/~orc/Code/discount/")
    (license bsd-3)))

(define-public perl-text-markdown-discount
  (package
    (name "perl-text-markdown-discount")
    (version "0.11")
    (source
     (origin
       (method url-fetch)
       (uri (string-append
             "mirror://cpan/authors/id/S/SE/SEKIMURA/Text-Markdown-Discount-"
             version
             ".tar.gz"))
       (sha256
        (base32
         "1xx7v3wnla7m6wa3h33whxw3vvincaicg4yra1b9wbzf2aix9rnw"))
       (patches
        (search-patches "perl-text-markdown-discount-unbundle.patch"))))
    (build-system perl-build-system)
    (arguments
     `(#:phases
       (modify-phases %standard-phases
         (add-before 'build 'set-ldflags
           (lambda* (#:key inputs #:allow-other-keys)
             (substitute* "Makefile"
               (("OTHERLDFLAGS = ")
                (string-append
                      "OTHERLDFLAGS = -lmarkdown -Wl,-rpath="
                      (assoc-ref inputs "discount")
                      "/lib")))
             #t)))))
    (inputs
     `(("discount" ,discount)))
    (home-page
     "https://metacpan.org/release/Text-Markdown-Discount")
    (synopsis
     "Fast function for converting Markdown to HTML using Discount")
    (description
     "Text::Markdown::Discount is a Perl extension to the Discount markdown
implementation.

@example
  use Text::Markdown::Discount;
  my $html = markdown($text)
@end example")
    (license perl-license)))

(define-public cmark
  (package
    (name "cmark")
    (version "0.29.0")
    (source (origin
             (method git-fetch)
             (uri (git-reference
                    (url "https://github.com/jgm/cmark")
                    (commit version)))
             (file-name (git-file-name name version))
             (sha256
              (base32
               "0r7jpqhgnssq444i8pwji2g36058vfzwkl70wbiwj13h4w5rfc8f"))
             (modules '((guix build utils)))
             (snippet
              '(begin
                 ;; Mimic upstream commit 68c3a91166347 to fix a test failure
                 ;; when using Python 3.8.  Remove for versions > 0.29.
                 ;; See <https://github.com/commonmark/cmark/issues/313>.
                 (substitute* "test/normalize.py"
                   (("cgi") "html"))
                 #t))))
    (build-system cmake-build-system)
    (arguments
     '(#:test-target "test"))
    (native-inputs `(("python" ,python)))
    (synopsis "CommonMark Markdown reference implementation")
    (description "CommonMark is a strongly defined, highly compatible
specification of Markdown.  cmark is the C reference implementation of
CommonMark.  It provides @code{libcmark} shared library for parsing
CommonMark to an abstract syntax tree (@dfn{AST}) and rendering the document
as HTML, groff man, LaTeX, CommonMark, or an XML representation of the
AST.  The package also provides the command-line program @command{cmark}
for parsing and rendering CommonMark.")
    (home-page "https://commonmark.org")
    ;; cmark is distributed with a BSD-2 license, but some components are Expat
    ;; licensed. The CommonMark specification is Creative Commons CC-BY-SA 4.0
    ;; licensed. See 'COPYING' in the source distribution for more information.
    (license (list bsd-2 expat cc-by-sa4.0))))

(define-public smu
  (package
    (name "smu")
    (version "1.5")
    (source
     (origin
       (method git-fetch)
       (uri (git-reference
             (url "https://github.com/Gottox/smu")
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
        (base32 "1jm7lhnzjx4q7gcwlkvsbffcy0zppywyh50d71ami6dnq182vvcc"))))
    (build-system gnu-build-system)
    (arguments
     `(#:make-flags (list "CC=gcc"
                          (string-append "PREFIX="
                                         (assoc-ref %outputs "out")))
       #:tests? #f                      ; no tests included
       #:phases
       (modify-phases %standard-phases
         (delete 'configure))))
    (home-page "https://github.com/Gottox/smu")
    (synopsis "Simple markup")
    (description
     "Smu is a very simple and minimal markup language.  It is
designed for using in wiki-like environments.  Smu makes it very
easy to write your documents on the fly and convert them into HTML.
Smu is capable to parse very large documents.  As long as you avoid an huge
amount of indents it scales just great.

Smu was started as a rewrite of Markdown but became something more
lightweight and consistent.  The biggest difference between Markdown
and smu is that smu doesn't support reference style links.")
    (license x11)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu packages marst)
  #:use-module (guix packages)
  #:use-module (guix licenses)
  #:use-module (guix download)
  #:use-module (gnu packages compression)
  #:use-module (guix build-system gnu))

(define-public marst
  (package
    (name "marst")
    (version "2.7")
    (source
     (origin
       (method url-fetch)
       (uri (string-append
             "mirror://gnu/" name "/" name "-" version
             ".tar.gz"))
       (sha256
        (base32 "0l6swjy8fjrqw89ghc1vvakg21jmpfkpsw92yssrzkg3rg8vkrry"))))
    (build-system gnu-build-system)
    (home-page "https://www.gnu.org/software/marst/")
    (synopsis "Algol-to-C translator")
    (description
     "GNU MARST is an Algol-to-C translator.  The package consists of the
translator itself, a library that contains the necessary Algol 60 procedures,
and a converter that converts existing Algol 60 programs from other
representations to the MARST representation.")
    (license gpl3+)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu packages mastodon)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix build-system python)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (gnu packages check)
  #:use-module (gnu packages time)
  #:use-module (gnu packages python-check)
  #:use-module (gnu packages python-crypto)
  #:use-module (gnu packages python-web)
  #:use-module (gnu packages python-xyz))

(define-public toot
  (package
    (name "toot")
    (version "0.27.0")
    (source
      (origin
        (method url-fetch)
        (uri (pypi-uri "toot" version))
        (sha256
         (base32 "1mfbqmgna7046d134pc5qx1vyfd60vwcn0xr9lxzlmc5rjdbmz8x"))))
    (build-system python-build-system)
    (arguments
     '(#:phases
       (modify-phases %standard-phases
         (replace 'check
           (lambda* (#:key inputs outputs #:allow-other-keys)
             (add-installed-pythonpath inputs outputs)
             (invoke "py.test"))))))
    (native-inputs
     `(("python-pytest" ,python-pytest)))
    (inputs
     `(("python-beautifulsoup4" ,python-beautifulsoup4)
       ("python-requests" ,python-requests)
       ("python-urwid" ,python-urwid)
       ("python-wcwidth" ,python-wcwidth)))
    (home-page "https://github.com/ihabunek/toot/")
    (synopsis "Mastodon CLI client")
    (description "Interact with Mastodon social network from the command line.
Features include:
@itemize
@item Posting, replying, deleting statuses
@item Support for media uploads, spoiler text, sensitive content
@item Search by account or hash tag
@item Following, muting and blocking accounts
@item Simple switching between authenticated in Mastodon accounts
@end itemize")
    (license license:gpl3)))

(define-public python-mastodon-py
  (package
    (name "python-mastodon-py")
    (version "1.5.1")
    (source
      (origin
        (method url-fetch)
        (uri (pypi-uri "Mastodon.py" version))
        (sha256
         (base32
          "1vikvkzcij2gd730cssigxi38vlmzqmwdy58r3y2cwsxifnxpz9a"))))
    (build-system python-build-system)
    (propagated-inputs
     `(("python-blurhash" ,python-blurhash)
       ("python-dateutil" ,python-dateutil)
       ("python-decorator" ,python-decorator)
       ("python-magic" ,python-magic)
       ("python-pytz" ,python-pytz)
       ("python-requests" ,python-requests)
       ("python-six" ,python-six)))
    (native-inputs
     `(("python-blurhash" ,python-blurhash)
       ("python-cryptography" ,python-cryptography)
       ("python-http-ece" ,python-http-ece)
       ("python-pytest" ,python-pytest)
       ("python-pytest-cov" ,python-pytest-cov)
       ("python-pytest-mock" ,python-pytest-mock)
       ("python-pytest-runner" ,python-pytest-runner)
       ("python-pytest-vcr" ,python-pytest-vcr)
       ("python-requests-mock" ,python-requests-mock)
       ("python-vcrpy" ,python-vcrpy)))
    (home-page "https://github.com/halcy/Mastodon.py")
    (synopsis "Python wrapper for the Mastodon API")
    (description
     "This package provides a python wrapper for the Mastodon API.")
    (license license:expat)))