code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 (guix build maven java)
  #:use-module (ice-9 peg)
  #:use-module (ice-9 textual-ports)
  #:export (parse-java-file))

(define-peg-pattern java-file body (and (* WS) (* (and top-level-statement
                                                       (* WS)))))
(define-peg-pattern WS none (or " " "\n" "\t" "\r"))
(define-peg-pattern top-level-statement body (or package import-pat class-pat comment inline-comment))
(define-peg-pattern package all (and (ignore "package") (* WS) package-name
                                     (* WS) (ignore ";")))
(define-peg-pattern import-pat all (and (ignore "import") (* WS)
                                        (? (and (ignore "static") (* WS)))
                                        package-name
                                        (* WS) (ignore ";")))
(define-peg-pattern comment all (and (? (and annotation-pat (* WS))) (ignore "/*")
                                     comment-part))
(define-peg-pattern comment-part body (or (ignore (and (* "*") "/"))
                                          (and (* "*") (+ comment-chr) comment-part)))
(define-peg-pattern comment-chr body (or "\t" "\n" (range #\ #\)) (range #\+ #\xffff)))
(define-peg-pattern inline-comment none (and (ignore "//") (* inline-comment-chr)
                                            (ignore "\n")))
(define-peg-pattern inline-comment-chr body (range #\ #\xffff))
(define-peg-pattern package-name body (* (or (range #\a #\z) (range #\A #\Z)
                                             (range #\0 #\9) "_" ".")))
(define-peg-pattern class-pat all (and (? (and annotation-pat (* WS)))
                                       (* (ignore (or inline-comment comment)))
                                       (? (and (ignore "private") (* WS)))
                                       (? (and (ignore "public") (* WS)))
                                       (? (and (ignore "static") (* WS)))
                                       (? (and (ignore "final") (* WS)))
                                       (? (and (ignore "abstract") (* WS)))
                                       (ignore "class")
                                       (* WS) package-name (* WS)
                                       (? extends)
                                       (? implements)
                                       (ignore "{") class-body (ignore "}")))
(define-peg-pattern extends all (? (and (ignore "extends") (* WS)
                                        package-name (* WS))))
(define-peg-pattern implements all (? (and (ignore "implements") (* WS)
                                           package-name (* WS))))
(define-peg-pattern annotation-pat all (and (ignore "@") package-name
                                            (? (and
                                                 (* WS)
                                                 (ignore "(") (* WS)
                                                 annotation-attr (* WS)
                                                 (* (and (ignore ",") (* WS)
                                                         annotation-attr (* WS)))
                                                 (ignore ")")))))
(define-peg-pattern annotation-attr all (or (and attr-name (* WS) (ignore "=")
                                                 (* WS) attr-value (* WS))
                                            attr-value))
(define-peg-pattern attr-name all (* (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9)
                                         "_")))
(define-peg-pattern attr-value all (or "true" "false"
                                       (+ (or (range #\0 #\9) (range #\a #\z)
                                              (range #\A #\Z) "." "_"))
                                       array-pat
                                       string-pat))
(define-peg-pattern array-pat body
  (and (ignore "{") (* WS) value
       (* (and (* WS) "," (* WS) value))
       (* WS) (ignore "}")))
(define-peg-pattern string-pat body (and (ignore "\"") (* string-chr) (ignore "\"")))
(define-peg-pattern string-chr body (or " " "!" (and (ignore "\\") "\"")
                                        (and (ignore "\\") "\\") (range #\# #\xffff)))

(define-peg-pattern class-body all (and (* WS) (* (and class-statement (* WS)))))
(define-peg-pattern class-statement body (or inline-comment comment param-pat
                                             method-pat class-pat))
(define-peg-pattern param-pat all (and (* (and annotation-pat (* WS)
                                               (? (ignore inline-comment))
                                               (* WS)))
                                       (? (and (ignore (or "private" "public"
                                                           "protected"))
                                               (* WS)))
                                       (? (and (ignore "static") (* WS)))
                                       (? (and (ignore "volatile") (* WS)))
                                       (? (and (ignore "final") (* WS)))
                                       type-name (* WS) param-name
                                       (? (and (* WS) (ignore "=") (* WS) value))
                                       (ignore ";")))
(define-peg-pattern value none (or string-pat (+ valuechr)))
(define-peg-pattern valuechr none (or comment inline-comment "\n"
                                      "\t" "\r"
                                      (range #\  #\:) (range #\< #\xffff)))
(define-peg-pattern param-name all (* (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9)
                                          "_")))
(define-peg-pattern type-name all type-pat)
(define-peg-pattern type-pat body
  (or "?"
      (and (* (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "_"))
           (? "...")
           (? "[]")
           (? type-param))))
(define-peg-pattern type-param body (and "<" (? type-pat)
                                         (* (and (* WS) "," (* WS) type-pat))
                                         (* WS) ">"))
(define-peg-pattern method-pat all (and (* (and annotation-pat (* WS)))
                                        (? (and (ignore (or "private" "public" "protected"))
                                                (* WS)))
                                        (? (and (ignore type-param) (* WS)))
                                        (? (and (ignore (or "abstract" "final"))
                                                (* WS)))
                                        (? (and (ignore "static") (* WS)))
                                        type-name (* WS) param-name (* WS)
                                        (ignore "(")
                                        param-list (ignore ")") (* WS)
                                        (? (and (ignore "throws") (* WS) package-name (* WS)
                                                (* (and (ignore ",") (* WS) package-name
                                                        (* WS)))))
                                        (or (ignore ";")
                                            (and (ignore "{") (* WS)
                                                 (? (and method-statements (* WS)))
                                            (ignore "}")))))
(define-peg-pattern param-list all (and (* WS) (* (and (? annotation-pat) (* WS)
                                                       type-name (* WS)
                                                       param-name (* WS)
                                                       (? (ignore ",")) (* WS)))))
(define-peg-pattern method-statements none (and (or (+ method-chr)
                                                    (and "{" method-statements "}")
                                                    string-pat)
                                                (? method-statements)))
(define-peg-pattern method-chr none (or "\t" "\n" "\r" " " "!" (range #\# #\z) "|"
                                        (range #\~ #\xffff)))

(define (parse-java-file file)
  (peg:tree (match-pattern java-file (call-with-input-file file get-string-all))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 (guix build maven plugin)
  #:use-module (guix build maven java)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:export (generate-mojo-from-files
	    default-convert-type
	    maven-convert-type))

(define-record-type mojo
  (make-mojo package name goal description requires-dependency-collection
             requires-dependency-resolution requires-direct-invocation?
             requires-project? requires-reports? aggregator? requires-online?
             inherited-by-default?  instantiation-strategy execution-strategy
             since thread-safe? phase parameters components)
  mojo?
  (package mojo-package)
  (name mojo-name)
  (goal mojo-goal)
  (description mojo-description)
  (requires-dependency-collection mojo-requires-dependency-collection)
  (requires-dependency-resolution mojo-requires-dependency-resolution)
  (requires-direct-invocation? mojo-requires-direct-invocation?)
  (requires-project? mojo-requires-project?)
  (requires-reports? mojo-requires-reports?)
  (aggregator? mojo-aggregator?)
  (requires-online? mojo-requires-online?)
  (inherited-by-default? mojo-inherited-by-default?)
  (instantiation-strategy mojo-instantiation-strategy)
  (execution-strategy mojo-execution-strategy)
  (since mojo-since)
  (thread-safe? mojo-thread-safe?)
  (phase mojo-phase)
  (parameters mojo-parameters)
  (components mojo-components))

(define* (update-mojo mojo
           #:key
           (package (mojo-package mojo))
           (name (mojo-name mojo))
           (goal (mojo-goal mojo))
           (description (mojo-description mojo))
           (requires-dependency-collection (mojo-requires-dependency-collection mojo))
           (requires-dependency-resolution (mojo-requires-dependency-resolution mojo))
           (requires-direct-invocation? (mojo-requires-direct-invocation? mojo))
           (requires-project? (mojo-requires-project? mojo))
           (requires-reports? (mojo-requires-reports? mojo))
           (aggregator? (mojo-aggregator? mojo))
           (requires-online? (mojo-requires-online? mojo))
           (inherited-by-default? (mojo-inherited-by-default? mojo))
           (instantiation-strategy (mojo-instantiation-strategy mojo))
           (execution-strategy (mojo-execution-strategy mojo))
           (since (mojo-since mojo))
           (thread-safe? (mojo-thread-safe? mojo))
           (phase (mojo-phase mojo))
           (parameters (mojo-parameters mojo))
           (components (mojo-components mojo)))
  (make-mojo package name goal description requires-dependency-collection
             requires-dependency-resolution requires-direct-invocation?
             requires-project? requires-reports? aggregator? requires-online?
             inherited-by-default? instantiation-strategy execution-strategy
             since thread-safe? phase parameters components))

(define-record-type mojo-parameter
  (make-mojo-parameter name type since required editable property description
                       configuration)
  mojo-parameter?
  (name          mojo-parameter-name)
  (type          mojo-parameter-type)
  (since         mojo-parameter-since)
  (required      mojo-parameter-required)
  (editable      mojo-parameter-editable)
  (property      mojo-parameter-property)
  (description   mojo-parameter-description)
  (configuration mojo-parameter-configuration))

(define* (update-mojo-parameter mojo-parameter
           #:key (name (mojo-parameter-name mojo-parameter))
                 (type (mojo-parameter-type mojo-parameter))
                 (since (mojo-parameter-since mojo-parameter))
                 (required (mojo-parameter-required mojo-parameter))
                 (editable (mojo-parameter-editable mojo-parameter))
                 (property (mojo-parameter-property mojo-parameter))
                 (description (mojo-parameter-description mojo-parameter))
                 (configuration (mojo-parameter-configuration mojo-parameter)))
  (make-mojo-parameter name type since required editable property description
                       configuration))

(define-record-type <mojo-component>
  (make-mojo-component field role hint)
  mojo-component?
  (field mojo-component-field)
  (role  mojo-component-role)
  (hint  mojo-component-hint))

(define* (update-mojo-component mojo-component
           #:key (field (mojo-component-field mojo-component))
                 (role (mojo-component-role mojo-component))
                 (hint (mojo-component-hint mojo-component)))
  (make-mojo-component field role hint))

(define (generate-mojo-parameter mojo-parameter)
  `(parameter (name ,(mojo-parameter-name mojo-parameter))
              (type ,(mojo-parameter-type mojo-parameter))
              ,@(if (mojo-parameter-since mojo-parameter)
                    `(since (mojo-parameter-since mojo-parameter))
                    '())
              (required ,(if (mojo-parameter-required mojo-parameter) "true" "false"))
              (editable ,(if (mojo-parameter-editable mojo-parameter) "true" "false"))
              (description ,(mojo-parameter-description mojo-parameter))))

(define (generate-mojo-configuration mojo-parameter)
  (let ((config (mojo-parameter-configuration mojo-parameter)))
    (if (or config (mojo-parameter-property mojo-parameter))
        `(,(string->symbol (mojo-parameter-name mojo-parameter))
           (@ ,@(cons (list 'implementation (mojo-parameter-type mojo-parameter))
                      (or config '())))
          ,@(if (mojo-parameter-property mojo-parameter)
                (list (string-append "${" (mojo-parameter-property mojo-parameter)
                                     "}"))
                '()))
        #f)))

(define (generate-mojo-component mojo-component)
  (let ((role (mojo-component-role mojo-component))
        (field (mojo-component-field mojo-component))
        (hint (mojo-component-hint mojo-component)))
    `(requirement
       (role ,role)
       ,@(if hint
          `((role-hint ,hint))
          '())
       (field-name ,field))))

(define (generate-mojo mojo)
  `(mojo
     (goal ,(mojo-goal mojo))
     (description ,(mojo-description mojo))
     ,@(let ((val (mojo-requires-dependency-collection mojo)))
         (if val
             `((requiresDependencyCollection ,val))
             '()))
     ,@(let ((val (mojo-requires-dependency-resolution mojo)))
         (if val
             `((requiresDependencyResolution ,val))
             '()))
     ,@(let ((val (mojo-requires-direct-invocation? mojo)))
         (if val
             `((requiresDirectInvocation ,val))
             '()))
     ,@(let ((val (mojo-requires-project? mojo)))
         (if val
             `((requiresProject ,val))
             '()))
     ,@(let ((val (mojo-requires-reports? mojo)))
         (if val
             `((requiresReports ,val))
             '()))
     ,@(let ((val (mojo-aggregator? mojo)))
         (if val
             `((aggregator ,val))
             '()))
     ,@(let ((val (mojo-requires-online? mojo)))
         (if val
             `((requiresOnline ,val))
             '()))
     ,@(let ((val (mojo-inherited-by-default? mojo)))
         (if val
             `((inheritedByDefault ,val))
             '()))
     ,@(let ((phase (mojo-phase mojo)))
             (if phase
                 `((phase ,phase))
                 '()))
     (implementation ,(string-append (mojo-package mojo) "." (mojo-name mojo)))
     (language "java")
     (instantiationStrategy ,(mojo-instantiation-strategy mojo))
     (executionStrategy ,(mojo-execution-strategy mojo))
     ,@(let ((since (mojo-since mojo)))
             (if since
                 `((since ,since))
                 '()))
     ,@(let ((val (mojo-thread-safe? mojo)))
         (if val
             `((threadSafe ,val))
             '()))
     (parameters
       ,(map generate-mojo-parameter (mojo-parameters mojo)))
     (configuration
       ,@(filter (lambda (a) a) (map generate-mojo-configuration (mojo-parameters mojo))))
     (requirements
       ,@(map generate-mojo-component (mojo-components mojo)))))

(define (default-convert-type type)
  (cond
    ((equal? type "String") "java.lang.String")
    ((equal? type "String[]") "java.lang.String[]")
    ((equal? type "File") "java.io.File")
    ((equal? type "File[]") "java.io.File[]")
    ((equal? type "List") "java.util.List")
    ((equal? type "Boolean") "java.lang.Boolean")
    ((equal? type "Properties") "java.util.Properties")
    ((and (> (string-length type) 5)
          (equal? (substring type 0 4) "Map<"))
     "java.util.Map")
    ((and (> (string-length type) 6)
          (equal? (substring type 0 5) "List<"))
     "java.util.List")
    ((and (> (string-length type) 15)
          (equal? (substring type 0 14) "LinkedHashSet<"))
     "java.util.LinkedHashSet")
    (else type)))

(define (maven-convert-type type)
  (cond
    ((equal? type "MavenProject")
     "org.apache.maven.project.MavenProject")
    (else (default-convert-type type))))

(define (update-mojo-from-file mojo file convert-type)
  (define parse-tree (parse-java-file file))

  (define (update-mojo-from-attrs mojo attrs)
    (let loop ((mojo mojo) (attrs attrs))
      (match attrs
        ('() mojo)
        ((attr attrs ...)
         (match attr
           (('annotation-attr ('attr-name name) ('attr-value value))
            (cond
              ((equal? name "name")
               (loop (update-mojo mojo #:goal value) attrs))
              ((equal? name "defaultPhase")
               (let* ((phase (car (reverse (string-split value #\.))))
                      (phase (string-downcase phase))
                      (phase (string-join (string-split phase #\_) "-")))
               (loop (update-mojo mojo #:phase phase) attrs)))
              ((equal? name "requiresProject")
               (loop (update-mojo mojo #:requires-project? value) attrs))
              ((equal? name "threadSafe")
               (loop (update-mojo mojo #:thread-safe? value) attrs))
              ((equal? name "aggregator")
               (loop (update-mojo mojo #:aggregator? value) attrs))
              ((equal? name "requiresDependencyCollection")
               (loop
                 (update-mojo mojo #:requires-dependency-collection
                              (match value
                                ("ResolutionScope.COMPILE" "compile")
                                ("ResolutionScope.COMPILE_PLUS_RUNTIME"
                                 "compile+runtime")
                                ("ResolutionScope.RUNTIME" "runtime")
                                ("ResolutionScope.RUNTIME_PLUS_SYSTEM"
                                 "runtime+system")
                                ("ResolutionScope.TEST" "test")
                                ("ResolutionScope.PROVIDED" "provided")
                                ("ResolutionScope.SYSTEM" "system")
                                ("ResolutionScope.IMPORT" "import")))
                 attrs))
              ((equal? name "requiresDependencyResolution")
               (loop
                 (update-mojo mojo #:requires-dependency-resolution
                              (match value
                                ("ResolutionScope.COMPILE" "compile")
                                ("ResolutionScope.COMPILE_PLUS_RUNTIME"
                                 "compile+runtime")
                                ("ResolutionScope.RUNTIME" "runtime")
                                ("ResolutionScope.RUNTIME_PLUS_SYSTEM"
                                 "runtime+system")
                                ("ResolutionScope.TEST" "test")
                                ("ResolutionScope.PROVIDED" "provided")
                                ("ResolutionScope.SYSTEM" "system")
                                ("ResolutionScope.IMPORT" "import")))
                 attrs))
              (else
                (throw 'not-found-attr name))))
           ((attrs ...) (loop mojo attrs))
           (_ (loop mojo attrs)))))))

  (define (string->attr name)
    (define (string-split-upper s)
      (let ((i (string-index s char-set:upper-case)))
        (if (and i (> i 0))
            (cons (substring s 0 i) (string-split-upper (substring s i)))
            (list s))))
    (string->symbol
      (string-join (map string-downcase (string-split-upper name)) "-")))

  (define (update-mojo-parameter-from-attrs mojo-parameter attrs)
    (match attrs
      ('() mojo-parameter)
      (('annotation-attr ('attr-name name) 'attr-value)
       mojo-parameter)
       ;(update-mojo-parameter-from-attrs mojo-parameter
       ;  `(annotation-attr (attr-name ,name) (attr-value ""))))
      (('annotation-attr ('attr-name name) ('attr-value value))
       (cond
         ((equal? name "editable")
          (update-mojo-parameter mojo-parameter #:editable value))
         ((equal? name "required")
          (update-mojo-parameter mojo-parameter #:required value))
         ((equal? name "property")
          (update-mojo-parameter mojo-parameter #:property value))
         (else
           (update-mojo-parameter mojo-parameter
                                  #:configuration
                                  (cons
                                    (list (string->attr name) value)
                                    (or
				      (mojo-parameter-configuration mojo-parameter)
				      '()))))))
      ((attr attrs ...)
       (update-mojo-parameter-from-attrs
         (update-mojo-parameter-from-attrs mojo-parameter attr)
         attrs))))

  (define (update-mojo-component-from-attrs mojo-component inverse-import attrs)
    (match attrs
      ('() mojo-component)
      ((attr attrs ...)
       (match attr
         (('annotation-attr ('attr-name name) ('attr-value value))
          (cond
            ((equal? name "role")
             (update-mojo-component-from-attrs
               (update-mojo-component mojo-component
                 #:role (select-import inverse-import value convert-type))
               inverse-import
               attrs))
            ((equal? name "hint")
             (update-mojo-component-from-attrs
               (update-mojo-component mojo-component #:hint value)
               inverse-import
               attrs))
            (else (throw 'not-found-attr name))))
         ((attrss ...)
          (update-mojo-component-from-attrs
            mojo-component inverse-import (append attrss attrs)))))))

  (define (add-mojo-parameter parameters name type last-comment attrs inverse-import)
    (let loop ((parameters parameters))
      (match parameters
        ('() (list (update-mojo-parameter-from-attrs
                     (make-mojo-parameter
                       ;; name convert since required editable property comment config
                       name (select-import inverse-import type convert-type)
                       #f #f #t #f last-comment #f)
                     attrs)))
        ((parameter parameters ...)
         (if (equal? (mojo-parameter-name parameter) name)
             (cons (update-mojo-parameter-from-attrs
                     (make-mojo-parameter
                       name (select-import inverse-import type convert-type)
                       #f #f #t #f last-comment #f)
                     attrs) parameters)
             (cons parameter (loop parameters)))))))

  (define (update-mojo-from-class-content mojo inverse-import content)
    (let loop ((content content)
               (mojo mojo)
               (last-comment #f))
      (match content
        ('() mojo)
        ((('comment ('annotation-pat _ ...) last-comment) content ...)
         (loop content mojo last-comment))
        ((('comment last-comment) content ...)
         (loop content mojo last-comment))
        ((('param-pat ('annotation-pat annot-name attrs ...) ('type-name type)
           ('param-name name)) content ...)
         (cond
           ((equal? annot-name "Parameter")
            (loop content
                  (update-mojo mojo
                               #:parameters
                               (add-mojo-parameter
                                 (mojo-parameters mojo) name type last-comment
                                 attrs inverse-import))
                  #f))
           ((equal? annot-name "Component")
            (loop content
                  (update-mojo mojo
                               #:components
                               (cons (update-mojo-component-from-attrs
                                       (make-mojo-component
                                         name
                                         (select-import inverse-import type
                                                        convert-type)
                                         #f)
                                       inverse-import
                                       attrs)
                                     (mojo-components mojo)))
                  #f))
           (else (throw 'not-found-annot annot-name))))
        ((('class-pat _ ...) content ...)
         (loop content mojo #f))
        ((('param-pat _ ...) content ...)
         (loop content mojo #f))
        ((('method-pat _ ...) content ...)
         (loop content mojo #f)))))

  (define (update-inverse-import inverse-import package)
    (let ((package-name (car (reverse (string-split package #\.)))))
      (cons (cons package-name package) inverse-import)))

  (define (select-import inverse-import package convert-type)
    (let* ((package (car (string-split package #\<)))
           (package (string-split package #\.))
           (rest (reverse (cdr package)))
           (rest (cond
                   ((null? rest) '())
                   ((equal? (car rest) "class") (cdr rest))
                   (else rest)))
           (base (or (assoc-ref inverse-import (car package)) (car package))))
      (convert-type (string-join (cons base rest) "."))))

  (let loop ((content parse-tree)
             (mojo mojo)
             (inverse-import '())
             (last-comment #f))
    (if (null? content)
        mojo
        (match content
          ((tls content ...)
           (match tls
             (('package package)
              (loop content (update-mojo mojo #:package package) inverse-import
                    last-comment))
             (('import-pat package)
              (loop content mojo (update-inverse-import inverse-import package)
                    last-comment))
             (('comment last-comment)
              (loop content mojo inverse-import last-comment))
             (('class-pat class-tls ...)
              (let loop2 ((class-tls class-tls) (mojo mojo))
                (match class-tls
                  ('() (loop content mojo inverse-import #f))
                  (((? string? name) class-tls ...)
                   (loop2 class-tls (update-mojo mojo #:name name)))
                  ((('annotation-pat annot-name (attrs ...)) class-tls ...)
                   (loop2
                     class-tls
                     (update-mojo-from-attrs mojo attrs)))
                  ((('class-body class-content ...) class-tls ...)
                   (loop2
                     class-tls
                     (update-mojo-from-class-content
                       mojo inverse-import class-content)))
                  ((_ class-tls ...)
                   (loop2 class-tls mojo)))))
             (_
              (loop content mojo inverse-import last-comment))))))))

(define (generate-mojo-from-files convert-type . files)
  (let ((mojo (make-mojo #f #f #f #f #f #f #f #f #f #f #f #f "per-lookup"
                         "once-per-session" #f #f #f '() '())))
    (let loop ((files files) (mojo mojo))
      (if (null? files)
          (generate-mojo mojo)
          (loop
            (cdr files)
            (update-mojo-from-file
              (update-mojo mojo
                #:package #f
                #:name #f
                #:goal #f
                #:description #f
                #:requires-dependency-resolution #f
                #:requires-direct-invocation? #f
                #:requires-project? #f
                #:requires-reports? #f
                #:aggregator? #f
                #:requires-online? #f
                #:inherited-by-default? #f
                #:instantiation-strategy "per-lookup"
                #:execution-strategy "once-per-session"
                #:since #f
                #:thread-safe? #f
                #:phase #f)
              (car files)
	      convert-type))))))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019-2021 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 (guix build maven pom)
  #:use-module (sxml simple)
  #:use-module (system foreign)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (add-local-package
            get-pom
            pom-ref
            pom-description
            pom-name
            pom-version
            pom-artifactid
            pom-groupid
            pom-dependencies
            group->dir
            pom-and-submodules
            pom-local-packages
            fix-pom-dependencies))

(define (add-local-package local-packages group artifact version)
  "Takes @var{local-packages}, a list of local packages, and adds a new one
for @var{group}:@var{artifact} at @var{version}."
  (define (alist-set lst key val)
    (match lst
      ('() (list (cons key val)))
      (((k . v) lst ...)
       (if (equal? k key)
         (cons (cons key val) lst)
         (cons (cons k v) (alist-set lst key val))))))
  (alist-set local-packages group
    (alist-set (or (assoc-ref local-packages group) '()) artifact
      version)))

(define (get-pom file)
  "Return the content of a @file{.pom} file."
  (let ((pom-content (call-with-input-file file xml->sxml)))
    (match pom-content
      (('*TOP* _ (_ ('@ _ ...) content ...))
        content)
      (('*TOP* (_ ('@ _ ...) content ...))
       content)
      (('*TOP* _ (_ content ...))
        content)
      (('*TOP* (_ content ...))
       content))))

(define (pom-ref content attr)
  "Gets a value associated to @var{attr} in @var{content}, an sxml value that
represents a @file{.pom} file content, or parts of it."
  (or
    (assoc-ref
      content
      (string->symbol
        (string-append "http://maven.apache.org/POM/4.0.0:" attr)))
    (assoc-ref content (string->symbol attr))))

(define (get-parent content)
  (pom-ref content "parent"))

(define* (find-parent content inputs #:optional local-packages)
  "Find the parent pom for the pom file with @var{content} in a package's
@var{inputs}.  When the parent pom cannot be found in @var{inputs}, but
@var{local-packages} is defined, the parent pom is looked up in it.

@var{local-packages} is an association list of groupID to an association list
of artifactID to version number.

The result is an sxml document that describes the content of the parent pom, or
of an hypothetical parent pom if it was generated from @var{local-packages}.
If no result is found, the result is @code{#f}."
  (let ((parent (pom-ref content "parent")))
    (if parent
        (let* ((groupid (car (pom-ref parent "groupId")))
               (artifactid (car (pom-ref parent "artifactId")))
               (version (car (pom-ref parent "version")))
               (pom-file (string-append "lib/m2/" (group->dir groupid)
                                        "/" artifactid "/" version "/"
                                        artifactid "-" version ".pom"))
               (java-inputs (filter
                              (lambda (input)
                                (file-exists? (string-append input "/" pom-file)))
                              inputs))
               (java-inputs (map (lambda (input) (string-append input "/" pom-file))
                                 java-inputs)))
          (if (null? java-inputs)
              (let ((version (assoc-ref (assoc-ref local-packages groupid) artifactid)))
                (if version
                    `((groupId ,groupid)
                      (artifactId ,artifactid)
                      (version ,version))
                    #f))
              (get-pom (car java-inputs))))
        #f)))

(define* (pom-groupid content)
  "Find the groupID of a pom file, potentially looking at its parent pom file.
See @code{find-parent} for the meaning of the arguments."
  (if content
    (let ((res (or (pom-ref content "groupId")
                   (pom-ref (pom-ref content "parent") "groupId"))))
      (cond
        ((string? res) res)
        ((null? res) #f)
        ((list? res) (car res))
        (else #f)))
    #f))

(define (pom-artifactid content)
  "Find the artifactID of a pom file, from its sxml @var{content}."
  (let ((res (pom-ref content "artifactId")))
    (if (and res (>= (length res) 1))
      (car res)
      #f)))

(define* (pom-version content)
  "Find the version of a pom file, potentially looking at its parent pom file.
See @code{find-parent} for the meaning of the arguments."
  (if content
    (let ((res (or (pom-ref content "version")
                   (pom-ref (pom-ref content "parent") "version"))))
      (cond
        ((string? res) res)
        ((null? res) #f)
        ((list? res) (car res))
        (else #f)))
    #f))

(define (pom-name content)
  "Return the name of the package as contained in the sxml @var{content} of the
pom file."
  (let ((res (pom-ref content "name")))
    (if (and res (>= (length res) 1))
      (car res)
      #f)))

(define (pom-description content)
  "Return the description of the package as contained in the sxml @var{content}
of the pom file."
  (let ((res (pom-ref content "description")))
    (if (and res (>= (length res) 1))
      (car res)
      #f)))

(define (pom-dependencies content)
  "Return the list of dependencies listed in the sxml @var{content} of the pom
file."
  (filter
    (lambda (a) a)
    (map
      (match-lambda
        ((? string? _) #f)
        (('http://maven.apache.org/POM/4.0.0:dependency content ...)
         (let loop ((content content) (groupid #f) (artifactid #f) (version #f) (scope #f))
           (match content
             ('()
              `(dependency
                 (groupId ,groupid)
                 (artifactId ,artifactid)
                 (version ,version)
                 ,@(if scope `((scope ,scope)) '())))
             (((? string? _) content ...)
              (loop content groupid artifactid version scope))
             ((('http://maven.apache.org/POM/4.0.0:scope scope) content ...)
              (loop content groupid artifactid version scope))
             ((('http://maven.apache.org/POM/4.0.0:groupId groupid) content ...)
              (loop content groupid artifactid version scope))
             ((('http://maven.apache.org/POM/4.0.0:artifactId artifactid) content ...)
              (loop content groupid artifactid version scope))
             ((('http://maven.apache.org/POM/4.0.0:version version) content ...)
              (loop content groupid artifactid version scope))
             ((_ content ...)
              (loop content groupid artifactid version scope))))))
      (pom-ref content "dependencies"))))

(define version-compare
  (let ((strverscmp
         (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
                        (error "could not find `strverscmp' (from GNU libc)"))))
           (pointer->procedure int sym (list '* '*)))))
    (lambda (a b)
      "Return '> when A denotes a newer version than B,
'< when A denotes a older version than B,
or '= when they denote equal versions."
      (let ((result (strverscmp (string->pointer a) (string->pointer b))))
        (cond ((positive? result) '>)
              ((negative? result) '<)
              (else '=))))))

(define (version>? a b)
  "Return #t when A denotes a version strictly newer than B."
  (eq? '> (version-compare a b)))

(define (fix-maven-xml sxml)
  "When writing an xml file from an sxml representation, it is not possible to
use namespaces in tag names.  This procedure takes an @var{sxml} representation
of a pom file and removes the namespace uses.  It also adds the required bits
to re-declare the namespaces in the top-level element."
  (define (fix-xml sxml)
    (match sxml
      ((tag ('@ opts ...) rest ...)
       (if (> (string-length (symbol->string tag))
              (string-length "http://maven.apache.org/POM/4.0.0:"))
         (let* ((tag (symbol->string tag))
                (tag (substring tag (string-length
                                      "http://maven.apache.org/POM/4.0.0:")))
                (tag (string->symbol tag)))
           `(,tag (@ ,@opts) ,@(map fix-xml rest)))
         `(,tag (@ ,@opts) ,@(map fix-xml rest))))
      ((tag (rest ...))
       (if (> (string-length (symbol->string tag))
              (string-length "http://maven.apache.org/POM/4.0.0:"))
         (let* ((tag (symbol->string tag))
                (tag (substring tag (string-length
                                      "http://maven.apache.org/POM/4.0.0:")))
                (tag (string->symbol tag)))
           `(,tag ,@(map fix-xml rest)))
         `(,tag ,@(map fix-xml rest))))
      ((tag rest ...)
       (if (> (string-length (symbol->string tag))
              (string-length "http://maven.apache.org/POM/4.0.0:"))
         (let* ((tag (symbol->string tag))
                (tag (substring tag (string-length
                                      "http://maven.apache.org/POM/4.0.0:")))
                (tag (string->symbol tag)))
           `(,tag ,@(map fix-xml rest)))
         `(,tag ,@(map fix-xml rest))))
      (_ sxml)))

  `((*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")
     (project (@ (xmlns "http://maven.apache.org/POM/4.0.0")
                 (xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance")
                 (xmlns:schemaLocation "http://maven.apache.org/POM/4.0.0
                   http://maven.apache.org/xsd/maven-4.0.0.xsd"))
       ,(map fix-xml sxml)))))

(define (pom-and-submodules pom-file)
  "Given @var{pom-file}, the file name of a pom, return the list of pom file
names that correspond to itself and its submodules, recursively."
  (define (get-modules modules)
    (match modules
      (#f '())
      ('() '())
      (((? string? _) rest ...) (get-modules rest))
      ((('http://maven.apache.org/POM/4.0.0:module mod) rest ...)
       (let ((pom (string-append (dirname pom-file) "/" mod "/pom.xml")))
         (if (file-exists? pom)
             (cons pom (get-modules rest))
             (get-modules rest))))))

  (let* ((pom (get-pom pom-file))
         (modules (get-modules (pom-ref pom "modules"))))
    (cons pom-file
          (apply append (map pom-and-submodules modules)))))

(define* (pom-local-packages pom-file #:key (local-packages '()))
  "Given @var{pom-file}, a pom file name, return a list of local packages that
this repository contains."
  (let loop ((modules (pom-and-submodules pom-file))
             (local-packages local-packages))
    (match modules
      (() local-packages)
      ((module modules ...)
       (let* ((pom (get-pom module))
              (version (pom-version pom))
              (artifactid (pom-artifactid pom))
              (groupid (pom-groupid pom)))
         (loop modules
               (add-local-package local-packages groupid artifactid version)))))))

(define (group->dir group)
  "Convert a group ID to a directory path."
  (string-join (string-split group #\.) "/"))

(define* (fix-pom-dependencies pom-file inputs
                               #:key with-plugins? with-build-dependencies?
                                     with-modules? (excludes '())
                                     (local-packages '()))
  "Open @var{pom-file}, and override its content, rewritting its dependencies
to set their version to the latest version available in the @var{inputs}.

@var{#:with-plugins?} controls whether plugins are also overridden.
@var{#:with-build-dependencies?} controls whether build dependencies (whose
scope is not empty) are also overridden.  By default build dependencies and
plugins are not overridden.

@var{#:excludes} is an association list of groupID to a list of artifactIDs.
When a pair (groupID, artifactID) is present in the list, its entry is
removed instead of being overridden.  If the entry is ignored because of the
previous arguments, the entry is not removed.

@var{#:local-packages} is an association list that contains additional version
information for packages that are not in @var{inputs}.  If the package is
not found in @var{inputs}, information from this list is used instead to determine
the latest version of the package.  This is an association list of group IDs
to another association list of artifact IDs to a version number.

Returns nothing, but overrides the @var{pom-file} as a side-effect."
  (define pom (get-pom pom-file))

  (define (ls dir)
    (let ((dir (opendir dir)))
      (let loop ((res '()))
        (let ((entry (readdir dir)))
          (if (eof-object? entry)
              res
              (loop (cons entry res)))))))

  (define fix-pom
    (match-lambda
      ('() '())
      ((tag rest ...)
       (match tag
         (('http://maven.apache.org/POM/4.0.0:dependencies deps ...)
          `((http://maven.apache.org/POM/4.0.0:dependencies ,(fix-deps deps))
            ,@(fix-pom rest)))
         (('http://maven.apache.org/POM/4.0.0:dependencyManagement deps ...)
          `((http://maven.apache.org/POM/4.0.0:dependencyManagement
              ,(fix-dep-management deps))
            ,@(fix-pom rest)))
         (('http://maven.apache.org/POM/4.0.0:build build ...)
          (if with-plugins?
              `((http://maven.apache.org/POM/4.0.0:build ,(fix-build build))
                ,@(fix-pom rest))
              (cons tag (fix-pom rest))))
         (('http://maven.apache.org/POM/4.0.0:modules modules ...)
          (if with-modules?
              `((http://maven.apache.org/POM/4.0.0:modules ,(fix-modules modules))
                ,@(fix-pom rest))
              (cons tag (fix-pom rest))))
         (tag (cons tag (fix-pom rest)))))))

  (define fix-modules
    (match-lambda
      ('() '())
      ((tag rest ...)
       (match tag
        (('http://maven.apache.org/POM/4.0.0:module module)
         (if (file-exists? (string-append (dirname pom-file) "/" module "/pom.xml"))
             `((http://maven.apache.org/POM/4.0.0:module ,module) ,@(fix-modules rest))
             (fix-modules rest)))
        (tag (cons tag (fix-modules rest)))))))

  (define fix-dep-management
    (match-lambda
      ('() '())
      ((tag rest ...)
       (match tag
         (('http://maven.apache.org/POM/4.0.0:dependencies deps ...)
          `((http://maven.apache.org/POM/4.0.0:dependencies ,(fix-deps deps #t))
            ,@(fix-dep-management rest)))
         (tag (cons tag (fix-dep-management rest)))))))

  (define* (fix-deps deps #:optional optional?)
    (match deps
      ('() '())
      ((tag rest ...)
       (match tag
         (('http://maven.apache.org/POM/4.0.0:dependency dep ...)
          `((http://maven.apache.org/POM/4.0.0:dependency ,(fix-dep dep optional?))
            ,@(fix-deps rest optional?)))
         (tag (cons tag (fix-deps rest optional?)))))))

  (define fix-build
    (match-lambda
      ('() '())
      ((tag rest ...)
       (match tag
         (('http://maven.apache.org/POM/4.0.0:pluginManagement management ...)
          `((http://maven.apache.org/POM/4.0.0:pluginManagement
              ,(fix-management management))
            ,@(fix-build rest)))
         (('http://maven.apache.org/POM/4.0.0:plugins plugins ...)
          `((http://maven.apache.org/POM/4.0.0:plugins
              ,(fix-plugins plugins))
            ,@(fix-build rest)))
         (('http://maven.apache.org/POM/4.0.0:extensions extensions ...)
          `((http://maven.apache.org/POM/4.0.0:extensions
              ,(fix-extensions extensions))
            ,@(fix-build rest)))
         (tag (cons tag (fix-build rest)))))))

  (define* (fix-extensions extensions #:optional optional?)
    (match extensions
      ('() '())
      ((tag rest ...)
       (match tag
         (('http://maven.apache.org/POM/4.0.0:extension extension ...)
          (let ((group (or (pom-groupid extension) "org.apache.maven.plugins"))
                (artifact (pom-artifactid extension)))
            (if (member artifact (or (assoc-ref excludes group) '()))
              (fix-extensions rest optional?)
              `((http://maven.apache.org/POM/4.0.0:extension
                  ,(fix-plugin extension optional?)); extensions are similar to plugins
                ,@(fix-extensions rest optional?)))))
         (tag (cons tag (fix-extensions rest optional?)))))))

  (define fix-management
    (match-lambda
      ('() '())
      ((tag rest ...)
       (match tag
         (('http://maven.apache.org/POM/4.0.0:plugins plugins ...)
          `((http://maven.apache.org/POM/4.0.0:plugins
              ,(fix-plugins plugins #t))
            ,@(fix-management rest)))
         (tag (cons tag (fix-management rest)))))))

  (define* (fix-plugins plugins #:optional optional?)
    (match plugins
      ('() '())
      ((tag rest ...)
       (match tag
         (('http://maven.apache.org/POM/4.0.0:plugin plugin ...)
          (let ((group (or (pom-groupid plugin) "org.apache.maven.plugins"))
                (artifact (pom-artifactid plugin)))
            (if (member artifact (or (assoc-ref excludes group) '()))
              (fix-plugins rest optional?)
              `((http://maven.apache.org/POM/4.0.0:plugin
                  ,(fix-plugin plugin optional?))
                ,@(fix-plugins rest optional?)))))
         (tag (cons tag (fix-plugins rest optional?)))))))

  (define* (fix-plugin plugin #:optional optional?)
    (let* ((artifact (pom-artifactid plugin))
           (group (or (pom-groupid plugin) "org.apache.maven.plugins"))
           (version (or (assoc-ref (assoc-ref local-packages group) artifact)
                        (find-version inputs group artifact optional?)
                        (pom-version plugin))))
      (if (pom-version plugin)
        (map
          (lambda (tag)
            (match tag
              (('http://maven.apache.org/POM/4.0.0:version _)
               `(http://maven.apache.org/POM/4.0.0:version ,version))
              (('version _)
               `(http://maven.apache.org/POM/4.0.0:version ,version))
              (tag tag)))
          plugin)
        (cons `(http://maven.apache.org/POM/4.0.0:version ,version) plugin))))

  (define* (fix-dep dep #:optional optional?)
    (let* ((artifact (pom-artifactid dep))
           (group (or (pom-groupid dep) (pom-groupid pom)))
           (scope (pom-ref dep "scope"))
           (is-optional? (equal? (pom-ref dep "optional") '("true"))))
      (format (current-error-port) "maven: ~a:~a :: ~a (optional: ~a)~%"
              group artifact scope optional?)
      (if (or (and (not (equal? scope '("test"))) (not is-optional?))
              with-build-dependencies?)
          (let ((version (or (assoc-ref (assoc-ref local-packages group) artifact)
                             (find-version inputs group artifact optional?)
                             (pom-version dep))))
            (if (pom-version dep)
              (map
                (lambda (tag)
                  (match tag
                    (('http://maven.apache.org/POM/4.0.0:version _)
                     `(http://maven.apache.org/POM/4.0.0:version ,version))
                    (('version _)
                     `(http://maven.apache.org/POM/4.0.0:version ,version))
                    (_ tag)))
                dep)
              (cons `(http://maven.apache.org/POM/4.0.0:version ,version) dep)))
          dep)))

  (define (find-packaged-version inputs group artifact)
    (let* ((directory (string-append "lib/m2/" (group->dir group)
                                     "/" artifact))
           (java-inputs (filter
                          (lambda (input)
                            (file-exists? (string-append input "/" directory)))
                          inputs))
           (java-inputs (map (lambda (input) (string-append input "/" directory))
                             java-inputs))
           (versions (append-map ls java-inputs))
           (versions (sort versions version>?)))
      (if (null? versions)
          #f
          (car versions))))

  (define* (find-version inputs group artifact #:optional optional?)
    (let ((packaged-version (find-packaged-version inputs group artifact))
          (local-version (assoc-ref (assoc-ref local-packages group) artifact)))
      (or local-version packaged-version
          (if optional?
            #f
            (begin
              (format (current-error-port) "maven: ~a:~a is missing from inputs~%"
                      group artifact)
              (throw 'no-such-input group artifact))))))

  (let ((tmpfile (string-append pom-file ".tmp")))
    (with-output-to-file tmpfile
      (lambda _
        (sxml->xml (fix-maven-xml (fix-pom pom)))))
    (rename-file tmpfile pom-file)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 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 (guix build meson-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module ((guix build glib-or-gtk-build-system) #:prefix glib-or-gtk:)
  #:use-module (guix build utils)
  #:use-module (guix build gremlin)
  #:use-module (guix elf)
  #:use-module (ice-9 match)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:export (%standard-phases
            meson-build))

;; Commentary:
;;
;; Builder-side code of the standard meson build procedure.
;;
;; Code:

(define* (configure #:key outputs configure-flags build-type
                    #:allow-other-keys)
  "Configure the given package."
  (let* ((out (assoc-ref outputs "out"))
         (source-dir (getcwd))
         (build-dir "../build")
         (prefix (assoc-ref outputs "out"))
         (args `(,(string-append "--prefix=" prefix)
                 ,(string-append "--buildtype=" build-type)
                 ,(string-append "-Dc_link_args=-Wl,-rpath="
                                 (assoc-ref outputs "out") "/lib")
                 ,(string-append "-Dcpp_link_args=-Wl,-rpath="
                                 (assoc-ref outputs "out") "/lib")
                 ,@configure-flags
                 ,source-dir)))

    (mkdir build-dir)
    (chdir build-dir)
    (apply invoke "meson" args)))

(define* (build #:key parallel-build?
                #:allow-other-keys)
  "Build a given meson package."
  (invoke "ninja" "-j" (if parallel-build?
                           (number->string (parallel-job-count))
                           "1")))

(define* (check #:key test-target parallel-tests? tests?
                #:allow-other-keys)
  (setenv "MESON_TESTTHREADS"
          (if parallel-tests?
              (number->string (parallel-job-count))
              "1"))
  (if tests?
      (invoke "ninja" test-target)
      (format #t "test suite not run~%"))
  #t)

(define* (install #:rest args)
  (invoke "ninja" "install"))

(define* (shrink-runpath #:key (elf-directories '("lib" "lib64" "libexec"
                                                  "bin" "sbin"))
                         outputs #:allow-other-keys)
  "Go through all ELF files from ELF-DIRECTORIES and shrink the RUNPATH
since a lot of directories are left over from the build phase of meson,
for example libraries only needed for the tests."

  (define handle-output
    (match-lambda
      ((output . directory)
       (let* ((elf-dirnames (map (lambda (subdir)
                                   (string-append directory "/" subdir))
                                 elf-directories))
              (existing-elf-dirs (filter (lambda (dir)
                                            (and (file-exists? dir)
                                                 (file-is-directory? dir)))
                                          elf-dirnames))
              (elf-pred (lambda (name stat)
                          (elf-file? name)))
              (elf-list (concatenate (map (lambda (dir)
                                            (find-files dir elf-pred))
                                          existing-elf-dirs))))
         (for-each strip-runpath elf-list)))))
  (for-each handle-output outputs)
  #t)

(define %standard-phases
  ;; The standard-phases of glib-or-gtk contains a superset of the phases
  ;; from the gnu-build-system.  If the glib-or-gtk? key is #f (the default)
  ;; then the extra phases will be removed again in (guix build-system meson).
  (modify-phases glib-or-gtk:%standard-phases
    (delete 'bootstrap)
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)
    (add-after 'strip 'shrink-runpath shrink-runpath)))

(define* (meson-build #:key inputs phases
                      #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; meson-build-system.scm ends here


code:
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; 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 (guix build minetest-build-system)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module ((guix build copy-build-system) #:prefix copy:)
  #:export (%standard-phases
            mod-install-plan minimise-png read-mod-name check))

;; (guix build copy-build-system) does not export 'install'.
(define copy:install
  (assoc-ref copy:%standard-phases 'install))

(define (mod-install-plan mod-name)
  `(("." ,(string-append "share/minetest/mods/" mod-name)
     ;; Only install files that will actually be used at run time.
     ;; This can save a little disk space.
     ;;
     ;; See <https://github.com/minetest/minetest/blob/master/doc/lua_api.txt>
     ;; for an incomple list of files that can be found in mods.
     #:include ("mod.conf" "modpack.conf" "settingtypes.txt" "depends.txt"
                "description.txt")
     #:include-regexp (".lua$" ".png$" ".ogg$" ".obj$" ".b3d$" ".tr$"
                       ".mts$"))))

(define* (guess-mod-name #:key inputs #:allow-other-keys)
  "Try to determine the name of the mod or modpack that is being built.
If it is unknown, make an educated guess."
  ;; Minetest doesn't care about the directory names in "share/minetest/mods"
  ;; so there is no technical problem if the directory names don't match
  ;; the mod names.  The directory can appear in the GUI if the modpack
  ;; doesn't have the 'name' set though, so try to make the guess.
  (define (guess)
    (let* ((source (assoc-ref inputs "source"))
           ;; Don't retain a reference to the store.
           (file-name (strip-store-file-name source))
           ;; The "minetest-" prefix is not informative, so strip it.
           (file-name (if (string-prefix? "minetest-" file-name)
                          (substring file-name (string-length "minetest-"))
                          file-name))
           ;; Strip "-checkout" suffixes of git checkouts.
           (file-name (if (string-suffix? "-checkout" file-name)
                          (substring file-name
                                     0
                                     (- (string-length file-name)
                                        (string-length "-minetest")))
                          file-name))
           (first-dot (string-index file-name #\.))
           ;; If the source code is in an archive (.tar.gz, .zip, ...),
           ;; strip the extension.
           (file-name (if first-dot
                          (substring file-name 0 first-dot)
                          file-name)))
      (format (current-error-port)
              "warning: the modpack ~a did not set 'name' in 'modpack.conf'~%"
              file-name)
      file-name))
  (cond ((file-exists? "mod.conf")
         (read-mod-name "mod.conf"))
        ((file-exists? "modpack.conf")
         (read-mod-name "modpack.conf" guess))
        (#t (guess))))

(define* (install #:key inputs #:allow-other-keys #:rest arguments)
  (apply copy:install
         #:install-plan (mod-install-plan (apply guess-mod-name arguments))
         arguments))

(define %png-magic-bytes
  ;; Magic bytes of PNG images, see ‘5.2 PNG signatures’ in
  ;; ‘Portable Network Graphics (PNG) Specification (Second Edition)’
  ;; on <https://www.w3.org/TR/PNG/>.
  #vu8(137 80 78 71 13 10 26 10))

(define png-file?
  ((@@ (guix build utils) file-header-match) %png-magic-bytes))

(define* (minimise-png #:key inputs native-inputs #:allow-other-keys)
  "Minimise PNG images found in the working directory."
  (define optipng (which "optipng"))
  (define (optimise image)
    (format #t "Optimising ~a~%" image)
    (make-file-writable (dirname image))
    (make-file-writable image)
    (define old-size (stat:size (stat image)))
    ;; The mod "technic" has a file "technic_music_player_top.png" that
    ;; actually is a JPEG file, see
    ;; <https://github.com/minetest-mods/technic/issues/590>.
    (if (png-file? image)
        (invoke optipng "-o4" "-quiet" image)
        (format #t "warning: skipping ~a because it's not actually a PNG image~%"
                image))
    (define new-size (stat:size (stat image)))
    (values old-size new-size))
  (define files (find-files "." ".png$"))
  (let loop ((total-old-size 0)
             (total-new-size 0)
             (images (find-files "." ".png$")))
    (cond ((pair? images)
           (receive (old-size new-size)
               (optimise (car images))
             (loop (+ total-old-size old-size)
                   (+ total-new-size new-size)
                   (cdr images))))
          ((= total-old-size 0)
           (format #t "There were no PNG images to minimise."))
          (#t
           (format #t "Minimisation reduced size of images by ~,2f% (~,2f MiB to ~,2f MiB)~%"
                   (* 100.0 (- 1 (/ total-new-size total-old-size)))
                   (/ total-old-size (expt 1024 2))
                   (/ total-new-size (expt 1024 2)))))))

(define name-regexp (make-regexp "^name[ ]*=(.+)$"))

(define* (read-mod-name mod.conf #:optional not-found)
  "Read the name of a mod from MOD.CONF.  If MOD.CONF
does not have a name field and NOT-FOUND is #false, raise an
error.  If NOT-FOUND is TRUE, call NOT-FOUND instead."
  (call-with-input-file mod.conf
    (lambda (port)
      (let loop ()
        (define line (read-line port))
        (if (eof-object? line)
            (if not-found
                (not-found)
                (error "~a does not have a 'name' field" mod.conf))
            (let ((match (regexp-exec name-regexp line)))
              (if (regexp-match? match)
                  (string-trim-both (match:substring match 1) #\ )
                  (loop))))))))

(define* (check #:key outputs tests? #:allow-other-keys)
  "Test whether the mod loads.  The mod must first be installed first."
  (define (all-mod-names directories)
    (append-map
     (lambda (directory)
       (map read-mod-name (find-files directory "mod.conf")))
     directories))
  (when tests?
    (mkdir "guix_testworld")
    ;; Add the mod to the mod search path, such that Minetest can find it.
    (setenv "MINETEST_MOD_PATH"
            (list->search-path-as-string
             (cons
              (string-append (assoc-ref outputs "out") "/share/minetest/mods")
              (search-path-as-string->list
               (or (getenv "MINETEST_MOD_PATH") "")))
             ":"))
    (with-directory-excursion "guix_testworld"
      (setenv "HOME" (getcwd))
      ;; Create a world in which all mods are loaded.
      (call-with-output-file "world.mt"
        (lambda (port)
          (display
           "gameid = minetest
world_name = guix_testworld
backend = sqlite3
player_backend = sqlite3
auth_backend = sqlite3
" port)
          (for-each
           (lambda (mod)
             (format port "load_mod_~a = true~%" mod))
           (all-mod-names (search-path-as-string->list
                           (getenv "MINETEST_MOD_PATH"))))))
      (receive (port pid)
          ((@@ (guix build utils) open-pipe-with-stderr)
           "xvfb-run" "--" "minetest" "--info" "--world" "." "--go")
        (format #t "Started Minetest with all mods loaded for testing~%")
        ;; Scan the output for error messages.
        ;; When the player has joined the server, stop minetest.
        (define (error? line)
          (and (string? line)
               (string-contains line ": ERROR[")))
        (define (stop? line)
          (and (string? line)
               (string-contains line "ACTION[Server]: singleplayer [127.0.0.1] joins game.")))
        (let loop ()
          (match (read-line port)
            ((? error? line)
             (error "minetest raised an error: ~a" line))
            ((? stop?)
             (kill pid SIGINT)
             (close-port port)
             (waitpid pid))
            ((? string? line)
             (display line)
             (newline)
             (loop))
            ((? eof-object?)
             (error "minetest didn't start"))))))))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (add-before 'build 'minimise-png minimise-png)
    (delete 'build)
    (delete 'check)
    (replace 'install install)
    ;; The 'check' phase requires the mod to be installed,
    ;; so move the 'check' phase after the 'install' phase.
    (add-after 'install 'check check)))

;;; minetest-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 (guix build minify-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module ((guix build minify-build-system) #:prefix minify:)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 popen)
  #:export (%standard-phases
            minify-build
            minify))

;; Commentary:
;;
;; Builder-side code of the standard minification procedure for JavaScript
;; files.
;;
;; Code:

(define* (minify file #:key target (directory ""))
  (format #t "minifying ~a\n" file)
  (let* ((base (basename file ".js"))
         (installed (or target (string-append directory base ".min.js")))
         (minified (open-pipe* OPEN_READ "uglifyjs" file)))
    (call-with-output-file installed
      (cut dump-port minified <>))
    #t))

(define* (build #:key javascript-files
                #:allow-other-keys)
  (let ((files (or javascript-files
                   (find-files "src" "\\.js$"))))
    (mkdir-p "guix/build")
    (every (cut minify <> #:directory "guix/build/") files)))

(define* (install #:key outputs #:allow-other-keys)
  (let* ((out (assoc-ref outputs "out"))
         (js  (string-append out "/share/javascript/")))
    (mkdir-p js)
    (for-each
      (lambda (file)
        (if (not (zero? (stat:size (stat file))))
          (install-file file js)
          (error "File is empty: " file)))
      (find-files "guix/build" "\\.min\\.js$")))
  #t)

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (replace 'build build)
    (delete 'check)
    (replace 'install install)))

(define* (minify-build #:key inputs (phases %standard-phases)
                       #:allow-other-keys #:rest args)
  "Build the given JavaScript package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; minify-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2020 Jelle Licht <jlicht@fsfe.org>
;;; Copyright © 2019, 2021 Timothy Sample <samplet@ngyro.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 (guix build node-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build json)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (%standard-phases
            node-build))

;; Commentary:
;;
;; Builder-side code of the standard Node/NPM package install procedure.
;;
;; Code:

(define (set-home . _)
  (with-directory-excursion ".."
    (let loop ((i 0))
      (let ((dir (string-append "npm-home-" (number->string i))))
        (if (directory-exists? dir)
            (loop (1+ i))
            (begin
              (mkdir dir)
              (setenv "HOME" (string-append (getcwd) "/" dir))
              (format #t "set HOME to ~s~%" (getenv "HOME")))))))
  #t)

(define (module-name module)
  (let* ((package.json (string-append module "/package.json"))
         (package-meta (call-with-input-file package.json read-json)))
    (assoc-ref package-meta "name")))

(define (index-modules input-paths)
  (define (list-modules directory)
    (append-map (lambda (x)
                  (if (string-prefix? "@" x)
                      (list-modules (string-append directory "/" x))
                      (list (string-append directory "/" x))))
                (filter (lambda (x)
                          (not (member x '("." ".."))))
                        (or (scandir directory) '()))))
  (let ((index (make-hash-table (* 2 (length input-paths)))))
    (for-each (lambda (dir)
                (let ((nm (string-append dir "/lib/node_modules")))
                  (for-each (lambda (module)
                              (hash-set! index (module-name module) module))
                            (list-modules nm))))
              input-paths)
    index))

(define* (patch-dependencies #:key inputs #:allow-other-keys)

  (define index (index-modules (map cdr inputs)))

  (define (resolve-dependencies package-meta meta-key)
    (fold (lambda (key+value acc)
            (match key+value
              ('@ acc)
              ((key . value) (acons key (hash-ref index key value) acc))))
          '()
          (or (assoc-ref package-meta meta-key) '())))

  (with-atomic-file-replacement "package.json"
    (lambda (in out)
      (let ((package-meta (read-json in)))
        (assoc-set! package-meta "dependencies"
                    (append
                     '(@)
                     (resolve-dependencies package-meta "dependencies")
                     (resolve-dependencies package-meta "peerDependencies")))
        (assoc-set! package-meta "devDependencies"
                    (append
                     '(@)
                     (resolve-dependencies package-meta "devDependencies")))
        (write-json package-meta out))))
  #t)

(define* (configure #:key outputs inputs #:allow-other-keys)
  (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
    (invoke npm "--offline" "--ignore-scripts" "install")
    #t))

(define* (build #:key inputs #:allow-other-keys)
  (let ((package-meta (call-with-input-file "package.json" read-json)))
    (if (and=> (assoc-ref package-meta "scripts")
               (lambda (scripts)
                 (assoc-ref scripts "build")))
        (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
          (invoke npm "run" "build"))
        (format #t "there is no build script to run~%"))
    #t))

(define* (check #:key tests? inputs #:allow-other-keys)
  "Run 'npm test' if TESTS?"
  (if tests?
      (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
        (invoke npm "test"))
      (format #t "test suite not run~%"))
  #t)

(define* (repack #:key inputs #:allow-other-keys)
  (invoke "tar"
          ;; Add options suggested by https://reproducible-builds.org/docs/archives/
          "--sort=name"
          (string-append "--mtime=@" (getenv "SOURCE_DATE_EPOCH"))
          "--owner=0"
          "--group=0"
          "--numeric-owner"
          "-czf" "../package.tgz" ".")
  #t)

(define* (install #:key outputs inputs #:allow-other-keys)
  "Install the node module to the output store item."
  (let ((out (assoc-ref outputs "out"))
        (npm (string-append (assoc-ref inputs "node") "/bin/npm")))
    (invoke npm "--prefix" out
            "--global"
            "--offline"
            "--loglevel" "info"
            "--production"
            "install" "../package.tgz")
    #t))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (add-after 'unpack 'set-home set-home)
    (add-before 'configure 'patch-dependencies patch-dependencies)
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    (add-before 'install 'repack repack)
    (replace 'install install)))

(define* (node-build #:key inputs (phases %standard-phases)
                     #:allow-other-keys #:rest args)
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 (guix build ocaml-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            ocaml-build))

;; Commentary:
;;
;; Builder-side code of the standard ocaml build procedure.
;;
;; Code:

(define* (ocaml-findlib-environment #:key outputs #:allow-other-keys)
  (let* ((out (assoc-ref outputs "out")))
    (setenv "OCAMLFIND_DESTDIR" (string-append out "/lib/ocaml/site-lib"))
    (setenv "OCAMLFIND_LDCONF" "ignore"))
  #t)

(define* (configure #:key outputs (configure-flags '())
                    (test-flags '("--enable-tests")) tests?
                    #:allow-other-keys)
  "Configure the given package."
  (let* ((out        (assoc-ref outputs "out")))
    (format #t "build directory: ~s~%" (getcwd))
    (if (file-exists? "setup.ml")
      (let ((args `("-configure"
                    "--prefix" ,out
                    ,@(if tests?
                          test-flags
                          '())
                    ,@configure-flags)))
        (format #t "running 'setup.ml' with arguments ~s~%" args)
        (apply invoke "ocaml" "setup.ml" args))
       (let ((args `("-prefix" ,out ,@configure-flags)))
        (format #t "running 'configure' with arguments ~s~%" args)
        (apply invoke "./configure" args))))
    #t)

(define* (build #:key inputs outputs (build-flags '()) (make-flags '())
                (use-make? #f) #:allow-other-keys)
  "Build the given package."
  (if (and (file-exists? "setup.ml") (not use-make?))
    (apply invoke "ocaml" "setup.ml" "-build" build-flags)
    (if (file-exists? "Makefile")
      (apply invoke "make" make-flags)
      (let ((file (if (file-exists? "pkg/pkg.ml") "pkg/pkg.ml" "pkg/build.ml")))
        (apply invoke "ocaml" "-I"
                      (string-append (assoc-ref inputs "findlib")
                                     "/lib/ocaml/site-lib")
                      file build-flags))))
  #t)

(define* (check #:key inputs outputs (make-flags '()) (test-target "test") tests?
                  (use-make? #f) #:allow-other-keys)
  "Install the given package."
  (when tests?
    (if (and (file-exists? "setup.ml") (not use-make?))
      (invoke "ocaml" "setup.ml" (string-append "-" test-target))
      (if (file-exists? "Makefile")
        (apply invoke "make" test-target make-flags)
        (let ((file (if (file-exists? "pkg/pkg.ml") "pkg/pkg.ml" "pkg/build.ml")))
          (invoke "ocaml" "-I"
                  (string-append (assoc-ref inputs "findlib")
                                 "/lib/ocaml/site-lib")
                  file test-target)))))
  #t)

(define* (install #:key outputs (build-flags '()) (make-flags '()) (use-make? #f)
                  (install-target "install")
                  #:allow-other-keys)
  "Install the given package."
  (let ((out (assoc-ref outputs "out")))
    (if (and (file-exists? "setup.ml") (not use-make?))
      (apply invoke "ocaml" "setup.ml"
             (string-append "-" install-target) build-flags)
      (if (file-exists? "Makefile")
        (apply invoke "make" install-target make-flags)
        (invoke "opam-installer" "-i" (string-append "--prefix=" out)
                (string-append "--libdir=" out "/lib/ocaml/site-lib")))))
  #t)

(define* (prepare-install #:key outputs #:allow-other-keys)
  "Prepare for building the given package."
  (mkdir-p (string-append (assoc-ref outputs "out") "/lib/ocaml/site-lib"))
  (mkdir-p (string-append (assoc-ref outputs "out") "/bin"))
  #t)

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure'
  ;; , `build', `check' and `install' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (add-before 'configure 'ocaml-findlib-environment
                ocaml-findlib-environment)
    (add-before 'install 'prepare-install prepare-install)
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)))

(define* (ocaml-build #:key inputs (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; ocaml-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@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 (guix build pack)
  #:use-module (guix build utils)
  #:export (tar-base-options))

(define* (tar-base-options #:key tar compressor)
  "Return the base GNU tar options required to produce deterministic archives
deterministically.  When TAR, a GNU tar command file name, is provided, the
`--sort' option is used only if supported.  When COMPRESSOR, a command such as
'(\"gzip\" \"-9n\"), is provided, the compressor is explicitly specified via
the `-I' option."
  (define (tar-supports-sort? tar)
    (with-error-to-port (%make-void-port "w")
      (lambda ()
        (zero? (system* tar "cf" "/dev/null" "--files-from=/dev/null"
                        "--sort=name")))))

  `(,@(if compressor
          (list "-I" (string-join compressor))
          '())
    ;; The --sort option was added to GNU tar in version 1.28, released
    ;; 2014-07-28.  For testing, we use the bootstrap tar, which is older
    ;; and doesn't support it.
    ,@(if (and=> tar tar-supports-sort?)
          '("--sort=name")
          '())
    ;; Use GNU format so there's no file name length limitation.
    "--format=gnu"
    "--mtime=@1"
    "--owner=root:0"
    "--group=root:0"
    ;; The 'nlink' of the store item files leads tar to store hard links
    ;; instead of actual copies.  However, the 'nlink' count depends on
    ;; deduplication in the store; it's an "implicit input" to the build
    ;; process.  Use '--hard-dereference' to eliminate it.
    "--hard-dereference"
    "--check-links"))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2015, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.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 (guix build perl-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            perl-build))

;; Commentary:
;;
;; Builder-side code of the standard Perl package build procedure.
;;
;; Code:

(define* (configure #:key outputs make-maker?
                    (make-maker-flags '()) (module-build-flags '())
                    #:allow-other-keys)
  "Configure the given Perl package."
  (let* ((out (assoc-ref outputs "out"))
         (args (cond
                ;; Prefer to use Module::Build unless otherwise told
                ((and (file-exists? "Build.PL")
                      (not make-maker?))
                 `("Build.PL" ,(string-append "--prefix=" out)
                   "--installdirs=site" ,@module-build-flags))
                ((file-exists? "Makefile.PL")
                 `("Makefile.PL" ,(string-append "PREFIX=" out)
                   ;; Prevent installation of 'perllocal.pod' files for
                   ;; determinism.  These are typically used to build a
                   ;; catalogue of installed packages, but does not provide
                   ;; any useful information when installed with a module.
                   "INSTALLDIRS=site" "NO_PERLLOCAL=1" ,@make-maker-flags))
                (else (error "no Build.PL or Makefile.PL found")))))
    (format #t "running `perl' with arguments ~s~%" args)
    (apply invoke "perl" args)))

(define-syntax-rule (define-w/gnu-fallback* (name args ...) body ...)
  (define* (name args ... #:rest rest)
    (if (access? "Build" X_OK)
        (begin body ...)
        (apply (assoc-ref gnu:%standard-phases 'name) rest))))

(define-w/gnu-fallback* (build)
  (invoke "./Build"))

(define-w/gnu-fallback* (check #:key target
                               (tests? (not target)) (test-flags '())
                               #:allow-other-keys)
  (if tests?
      (apply invoke "./Build" "test" test-flags)
      (format #t "test suite not run~%"))
  #t)

(define-w/gnu-fallback* (install)
  (invoke "./Build" "install"))

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure',
  ;; `build', `check', and `install' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (replace 'install install)
    (replace 'check check)
    (replace 'build build)
    (replace 'configure configure)))

(define* (perl-build #:key inputs (phases %standard-phases)
                     #:allow-other-keys #:rest args)
  "Build the given Perl package, applying all of PHASES in order."
  (apply gnu:gnu-build
         #:inputs inputs #:phases phases
         args))

;;; perl-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Ludovic Courtès <ludo@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 (guix build po)
  #:use-module (ice-9 match)
  #:use-module (ice-9 peg)
  #:use-module (ice-9 textual-ports)
  #:export (read-po-file))

;; A small parser for po files
(define-peg-pattern po-file body (* (or comment entry whitespace)))
(define-peg-pattern whitespace body (or " " "\t" "\n"))
(define-peg-pattern comment-chr body (range #\space #\頋))
(define-peg-pattern comment none (and "#" (* comment-chr) "\n"))
(define-peg-pattern entry all
  (and (ignore (* whitespace)) (ignore "msgid ") msgid
       (ignore (* whitespace)) (ignore "msgstr ") msgstr))
(define-peg-pattern escape body (or "\\\\" "\\\"" "\\n"))
(define-peg-pattern str-chr body (or " " "!" (and (ignore "\\") "\"")
                                     "\\n" (and (ignore "\\") "\\")
                                     (range #\# #\頋)))
(define-peg-pattern msgid all content)
(define-peg-pattern msgstr all content)
(define-peg-pattern content body
  (and (ignore "\"") (* str-chr) (ignore "\"")
       (? (and (ignore (* whitespace)) content))))

(define (interpret-newline-escape str)
  "Replace '\\n' sequences in STR with a newline character."
  (let loop ((str str)
             (result '()))
    (match (string-contains str "\\n")
      (#f (string-concatenate-reverse (cons str result)))
      (index
       (let ((prefix (string-take str index)))
         (loop (string-drop str (+ 2 index))
               (append (list "\n" prefix) result)))))))

(define (parse-tree->assoc parse-tree)
  "Converts a po PARSE-TREE to an association list."
  (match parse-tree
    (() '())
    ((entry . parse-tree)
     (match entry
       ((? string? entry)
        (parse-tree->assoc parse-tree))
       ;; empty msgid
       (('entry ('msgid ('msgstr msgstr)))
        (parse-tree->assoc parse-tree))
       ;; empty msgstr
       (('entry ('msgid msgid) 'msgstr)
        (parse-tree->assoc parse-tree))
       (('entry ('msgid msgid) ('msgstr msgstr))
        (acons (interpret-newline-escape msgid)
               (interpret-newline-escape msgstr)
               (parse-tree->assoc parse-tree)))))))

(define (read-po-file port)
  "Read a .po file from PORT and return an alist of msgid and msgstr."
  (let ((tree (peg:tree (match-pattern
                          po-file
                          (get-string-all port)))))
    (parse-tree->assoc tree)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@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 (guix build profiles)
  #:use-module (guix build union)
  #:use-module (guix build utils)
  #:use-module (guix search-paths)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:re-export (symlink-relative)                  ;for convenience
  #:export (ensure-writable-directory
            build-profile))

;;; Commentary:
;;;
;;; Build a user profile (essentially the union of all the installed packages)
;;; with its associated meta-data.
;;;
;;; Code:

(define (abstract-profile profile)
  "Return a procedure that replaces PROFILE in VALUE with a reference to the
'GUIX_PROFILE' environment variable.  This allows users to specify what the
user-friendly name of the profile is, for instance ~/.guix-profile rather than
/gnu/store/...-profile."
  (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}"))
        (crop        (cute string-drop <> (string-length profile))))
    (match-lambda
      ((search-path . value)
       (match (search-path-specification-separator search-path)
         (#f
          (cons search-path
                (string-append replacement (crop value))))
         ((? string? separator)
          (let ((items (string-tokenize* value separator)))
            (cons search-path
                  (string-join (map (lambda (str)
                                      (string-append replacement (crop str)))
                                    items)
                               separator)))))))))

(define (write-environment-variable-definition port)
  "Write the given environment variable definition to PORT."
  (match-lambda
    ((search-path . value)
     (display (search-path-definition search-path value #:kind 'prefix)
              port)
     (newline port))))

(define (build-etc/profile output search-paths)
  "Build the 'OUTPUT/etc/profile' shell file containing environment variable
definitions for all the SEARCH-PATHS."
  (define file
    (string-append output "/etc/profile"))

  (mkdir-p (dirname file))
  (when (file-exists? file)
    (delete-file file))

  (call-with-output-file file
    (lambda (port)
      ;; The use of $GUIX_PROFILE described below is not great.  Another
      ;; option would have been to use "$1" and have users run:
      ;;
      ;;   source ~/.guix-profile/etc/profile ~/.guix-profile
      ;;
      ;; However, when 'source' is used with no arguments, $1 refers to the
      ;; first positional parameter of the calling script, so we cannot rely
      ;; on it.
      (display "\
# Source this file to define all the relevant environment variables in Bash
# for this profile.  You may want to define the 'GUIX_PROFILE' environment
# variable to point to the \"visible\" name of the profile, like this:
#
#  GUIX_PROFILE=/path/to/profile ; \\
#  source /path/to/profile/etc/profile
#
# When GUIX_PROFILE is undefined, the various environment variables refer
# to this specific profile generation.
\n" port)
      (let ((variables (evaluate-search-paths search-paths
                                              (list output))))
        (for-each (write-environment-variable-definition port)
                  (map (abstract-profile output) variables))))))

(define* (ensure-writable-directory directory
                                    #:key (symlink symlink))
  "Ensure DIRECTORY exists and is writable.  If DIRECTORY is currently a
symlink (to a read-only directory in the store), then delete the symlink and
instead make DIRECTORY a \"real\" directory containing symlinks."
  (define (absolute? file)
    (string-prefix? "/" file))

  (define (unsymlink link)
    (let* ((target (match (readlink link)
                     ((? absolute? target)
                      target)
                     ((? string? relative)
                      (string-append (dirname link) "/" relative))))
           ;; TARGET might itself be a symlink, so append "/" to make sure
           ;; 'scandir' enters it.
           (files  (scandir (string-append target "/")
                            (negate (cut member <> '("." ".."))))))
      (delete-file link)
      (mkdir link)
      (for-each (lambda (file)
                  (symlink (string-append target "/" file)
                           (string-append link "/" file)))
                files)))

  (catch 'system-error
    (lambda ()
      (mkdir directory))
    (lambda args
      (let ((errno (system-error-errno args)))
        (if (= errno EEXIST)
            (let ((stat (lstat directory)))
              (case (stat:type stat)
                ((symlink)
                 ;; "Unsymlink" DIRECTORY so that it is writable.
                 (unsymlink directory))
                ((directory)
                 #t)
                (else
                 (error "cannot mkdir because a same-named file exists"
                        directory))))
            (apply throw args))))))

(define (manifest-sexp->inputs+search-paths manifest)
  "Parse MANIFEST, an sexp as produced by 'manifest->gexp', and return two
values: the list of store items of its manifest entries, and the list of
search path specifications."
  (match manifest                            ;this must match 'manifest->gexp'
    (('manifest ('version 3)
                ('packages (entries ...)))
     (let loop ((entries entries)
                (inputs '())
                (search-paths '()))
       (match entries
         (((name version output item
                 ('propagated-inputs deps)
                 ('search-paths paths) _ ...) . rest)
          (loop (append rest deps)                ;breadth-first traversal
                (cons item inputs)
                (append paths search-paths)))
         (()
          (values (reverse inputs)
                  (delete-duplicates
                   (cons $PATH
                         (map sexp->search-path-specification
                              (reverse search-paths)))))))))))

(define* (build-profile output manifest
                        #:key (extra-inputs '()) (symlink symlink))
  "Build a user profile from MANIFEST, an sexp, and EXTRA-INPUTS, a list of
store items, in directory OUTPUT, using SYMLINK to create symlinks.  Create
OUTPUT/etc/profile with Bash definitions for all the variables listed in the
search paths of MANIFEST's entries."
  (define manifest-file
    (string-append output "/manifest"))

  (let-values (((inputs search-paths)
                (manifest-sexp->inputs+search-paths manifest)))

    ;; Make the symlinks.
    (union-build output (append extra-inputs inputs)
                 #:symlink symlink
                 #:log-port (%make-void-port "w"))

    ;; If one of the INPUTS provides a '/manifest' file, delete it.  That can
    ;; happen if MANIFEST contains something such as a Guix instance, which is
    ;; ultimately built as a profile.
    (when (file-exists? manifest-file)
      (delete-file manifest-file))

    ;; Store meta-data.
    (call-with-output-file manifest-file
      (lambda (p)
        (display "\
;; This file was automatically generated and is for internal use only.
;; It cannot be passed to the '--manifest' option.
;; Run 'guix package --export-manifest' if you want to export a file
;; suitable for '--manifest'.\n\n"
                 p)
        (pretty-print manifest p)))

    ;; Make sure we can write to 'OUTPUT/etc'.  'union-build' above could have
    ;; made 'etc' a symlink to a read-only sub-directory in the store so we
    ;; need to work around that.
    (ensure-writable-directory (string-append output "/etc")
                               #:symlink symlink)

    ;; Write 'OUTPUT/etc/profile'.
    (build-etc/profile output search-paths)))

;;; profile.scm ends here