;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Alex Vong <alexvong1995@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 build-flags)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:export (flag-list
            flag-list+
            flag-list-
            flag-list->string-list
            default-flag-list
            format-flag-list
            fortify-flag-list
            stackprotector-flag-list
            stackprotectorstrong-flag-list
            relro-flag-list
            bindnow-flag-list
            pie-flag-list
            all-flag-list))

;;; Commentary:
;;;
;;; Module to manipulate build flags, similar to dpkg-buildflags.
;;;
;;; Data structure <flag-list> is constructed by flag-list.
;;; The constructor flag-list does something to its arguments,
;;; such as trimming white-spaces, to ensure no two arguments mean the same.
;;;
;;; Here is an example:
;;; (define default-flag-list
;;;   (flag-list
;;;    #:CFLAGS '("-O2" "-g")
;;;    #:LDFLAGS '("-lm" "-lpthread")))
;;;
;;; flag-list+ and flag-list- are analogous to
;;; numeric + and - but operate on <flag-list>.
;;;
;;; flag-list->string-list converts <flag-list> into
;;; configure-flags-compatible string-list.
;;;
;;; Code:


;;; Pair up a symbol with a procedure so that we know
;;; what identifier is bound to the procedure at macro-expand time.
(define-record-type <identifier-procedure-pair>
  (cons-identifier-procedure id proc)
  identifier-procedure-pair?
  (id identifier)
  (proc procedure))

(define-syntax define-record-type-with-accessor-list
  (syntax-rules ()
    "Macro to define a srfi-9 record
with accessor list bound to accessor-list-name.
"
    ((_ record-name
        (constructor-name field-name* ...)
        predicate-name
        accessor-list-name
        (field-name accessor-name) ...)
     (begin
       (define-record-type record-name
         (constructor-name field-name* ...)
         predicate-name
         (field-name accessor-name) ...)
       (define accessor-list-name
         `(,(cons-identifier-procedure 'accessor-name
                                       accessor-name) ...))))))

;;; define <flag-list> using define-record-type-with-accessor-list macro
(define-record-type-with-accessor-list <flag-list>
  (make-flag-list c-flags
                  cpp-flags
                  c++-flags
                  fc-flags
                  f-flags
                  gcj-flags
                  ld-flags
                  objc-flags
                  objc++-flags)
  flag-list?
  flag-list-accessor-list
  (c-flags CFLAGS)
  (cpp-flags CPPFLAGS)
  (c++-flags CXXFLAGS)
  (fc-flags FCFLAGS)
  (f-flags FFLAGS)
  (gcj-flags GCJFLAGS)
  (ld-flags LDFLAGS)
  (objc-flags OBJCFLAGS)
  (objc++-flags OBJCXXFLAGS))


(define-syntax define*-with-keyword-list
  (syntax-rules ()
    "Macro to define a procedure with keyword and default arguments
only with keyword list bound to keyword-list-name.
"
    ((_ (proc-name keyword-list-name
                   (keyword default-val) ...)
        body)
     (begin
       (define* (proc-name #:key
                           (keyword default-val) ...)
         body)
       (define keyword-list-name
         (map symbol->keyword
              '(keyword ...)))))))

;;; Constructor for <flag-list>
;;; with keyword list bound to flag-list-keyword-list.
(define*-with-keyword-list (flag-list flag-list-keyword-list
                                      (CFLAGS '())
                                      (CPPFLAGS '())
                                      (CXXFLAGS '())
                                      (FCFLAGS '())
                                      (FFLAGS '())
                                      (GCJFLAGS '())
                                      (LDFLAGS '())
                                      (OBJCFLAGS '())
                                      (OBJCXXFLAGS '()))
  (apply make-flag-list
         (map (lambda (string-list)
                (map string-trim-both string-list))
              (list CFLAGS
                    CPPFLAGS
                    CXXFLAGS
                    FCFLAGS
                    FFLAGS
                    GCJFLAGS
                    LDFLAGS
                    OBJCFLAGS
                    OBJCXXFLAGS))))

(define (keyword-apply proc kw-list kw-arg-list by-position-arg-list)
  "keyword-apply is inspired by the same-name procedure in Racket.
It applies a procedure using keyword list and keyword argument list.
"
  (apply proc
         (append (concatenate (zip kw-list
                                   kw-arg-list))
                 by-position-arg-list)))


(define (flag-list-operation lset-operation)
  "Take a lset operation.
Return a procedure that takes any number of <flag-list>
and does the set operation on them for each flags respectively
"
  (define (list-of-string-list-operation list-of-string-list)
    (apply lset-operation
           `(,string=? ,@list-of-string-list)))
  (lambda list-of-flag-list
    (let ((flag-list-proc-list (map procedure
                                    flag-list-accessor-list)))
      (keyword-apply flag-list
                     flag-list-keyword-list
                     (map (lambda (proc)
                            (list-of-string-list-operation
                             (map proc list-of-flag-list)))
                          flag-list-proc-list)
                   '()))))

;;; union any number of <flag-list> for each flags
(define flag-list+
  (flag-list-operation lset-union))

;;; take the first <flag-list> and minus the union of the rest for each flags
(define flag-list-
  (flag-list-operation lset-difference))

(define (flag-list->string-list flag-lst)
  "Convert <flag-list> into configure-flags-compatible string list.
"
  (map (lambda (accessor)
         (let ((id (identifier accessor))
               (proc (procedure accessor)))
           (string-append (symbol->string id)
                          "="
                          (string-join (proc flag-lst)))))
       flag-list-accessor-list))


;;; build flags used in dpkg-buildflags

(define default-flag-list
  (flag-list
   #:CFLAGS '("-g" "-O2")
   #:CXXFLAGS '("-g" "-O2")
   #:FCFLAGS '("-g" "-O2")
   #:FFLAGS '("-g" "-O2")
   #:GCJFLAGS '("-g" "-O2")
   #:OBJCFLAGS '("-g" "-O2")
   #:OBJCXXFLAGS '("-g" "-O2")))

(define format-flag-list
  (flag-list
   #:CFLAGS '("-Wformat" "-Werror=format-security")
   #:CXXFLAGS '("-Wformat" "-Werror=format-security")
   #:OBJCFLAGS '("-Wformat" "-Werror=format-security")
   #:OBJCXXFLAGS '("-Wformat" "-Werror=format-security")))

(define fortify-flag-list
  (flag-list
   #:CPPFLAGS '("-D_FORTIFY_SOURCE=2")))

(define stackprotector-flag-list
  (flag-list
   #:CFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
   #:CXXFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
   #:FCFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
   #:FFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
   #:GCJFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
   #:OBJCFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
   #:OBJCXXFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")))

(define stackprotectorstrong-flag-list
  (flag-list
   #:CFLAGS '("-fstack-protector-strong")
   #:CXXFLAGS '("-fstack-protector-strong")
   #:FCFLAGS '("-fstack-protector-strong")
   #:FFLAGS '("-fstack-protector-strong")
   #:GCJFLAGS '("-fstack-protector-strong")
   #:OBJCFLAGS '("-fstack-protector-strong")
   #:OBJCXXFLAGS '("-fstack-protector-strong")))

(define relro-flag-list
  (flag-list
   #:LDFLAGS '("-Wl,-z,relro")))

(define bindnow-flag-list
  (flag-list
   #:LDFLAGS '("-Wl,-z,now")))

(define pie-flag-list
  (flag-list
   #:CFLAGS '("-fPIE")
   #:CXXFLAGS '("-fPIE")
   #:FCFLAGS '("-fPIE")
   #:FFLAGS '("-fPIE")
   #:GCJFLAGS '("-fPIE")
   #:LDFLAGS '("-fPIE" "-pie")
   #:OBJCFLAGS '("-fPIE")
   #:OBJCXXFLAGS '("-fPIE")))

(define all-flag-list
  (flag-list+ default-flag-list
              format-flag-list
              fortify-flag-list
              stackprotectorstrong-flag-list
              relro-flag-list
              bindnow-flag-list
              pie-flag-list))

;;; build-flags.scm ends here