;;; 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 (gnu packages mlucas)
  #:use-module (srfi srfi-1)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix build-system gnu)
  #:use-module (guix licenses)
  #:use-module (gnu packages autogen)
  #:use-module (gnu packages autotools)
  #:use-module (gnu packages perl))


;;; Procedures to manupulate build flags, similar to dpkg-buildflags.
;;;
;;; The data strcture flag-list is constrcuted by (flag-list <flag-sublist>...)
;;; The constructor flag-list does something to the argument,
;;; such as trimming whitespaces, to ensure no two arguments mean the same.
;;;
;;; The data structure flag-sublist is in fact an ordinary list
;;; with the following structure (<flag-type-symbol> <flag-string>...)
;;;
;;; Here is an example:
;;; (flag-list
;;;  '(CFLAGS "-O2" "-g")
;;;  '(LDFLAGS "-lm" "-lpthread"))
;;;
;;; flag-list+ and flag-list- are analogous to
;;; numberic + and - but operate on flag-list.
;;;
;;; flag-list->string-list converts flag-list into
;;; configure-flags-compatible string-list.
;;;

;;; selectors of flag-sublist
(define (flag-type flag-sublist)
  (car flag-sublist))
(define (flag-string-list flag-sublist)
  (cdr flag-sublist))

;;; constructor of flag-list
(define (flag-list . flag-lst)
  ;; Trim leading and trailing whitespaces of all flag-string
  ;; in flag-list.
  (define (trim-flag-string flag-lst)
    (map (λ(flag-sublist)
           (cons (flag-type flag-sublist)
                 (map string-trim-both
                      (flag-string-list flag-sublist))))
         flag-lst))
  ;; Sort flag-list using flag-type of flag-sublist,
  ;; this will make it easier to add two flag-list together.
  (define (sort-flag-list flag-lst)
    (sort-list flag-lst
               (λ(a b)
                 (string<? (symbol->string (flag-type a))
                           (symbol->string (flag-type b))))))
  ;; Given a sorted flag-list,
  ;; combine flag-sublist which have the same flag-type.
  (define (merge-sorted-flag-list flag-lst)
    (letrec ( ; append 2 flag-sublist and make sure no duplicate flag-string
             (append-flag-sublist
              (λ(flag-sublist1 flag-sublist2)
                (cond ((null? flag-sublist1) flag-sublist2)
                      ((null? flag-sublist2) flag-sublist1)
                      (else
                       (cons (flag-type flag-sublist1)
                             (lset-union string=?
                                         (flag-string-list flag-sublist1)
                                         (flag-string-list flag-sublist2)))))))
             ;; join list of flag-sublist using append-flag-sublist
             (join-flag-sublist
              (λ(list-of-flag-sublist)
                (fold append-flag-sublist '() list-of-flag-sublist))))
      (if (null? flag-lst)
          '()
          (let* ((current-type (flag-type (car flag-lst)))
                 (same-type? (λ(flag-sublist)
                               (eq? (flag-type flag-sublist)
                                    current-type))))
            (cons (join-flag-sublist
                   (take-while same-type? flag-lst))
                  (merge-sorted-flag-list
                   (drop-while same-type? flag-lst)))))))
  ((compose merge-sorted-flag-list
            sort-flag-list
            trim-flag-string)
   flag-lst))

;;; set-like operators for flag-list
(define (flag-list+ . list-of-flag-list)
  (apply flag-list (concatenate list-of-flag-list)))
(define (flag-list- flag-list1 . list-of-flag-list)
  (define (flag-list-difference flag-sublist1 flag-list)
    (let ((found (find (λ(flag-sublist2)
                         (eq? (flag-type flag-sublist1)
                              (flag-type flag-sublist2)))
                       flag-list)))
      (if (eq? found #f)
          flag-sublist1
          (cons (flag-type flag-sublist1)
                (lset-difference string=?
                                 (flag-string-list flag-sublist1)
                                 (flag-string-list found))))))
  (let ((flag-list2 (apply flag-list+ list-of-flag-list)))
    (map (λ(flag-sublist)
           (flag-list-difference flag-sublist flag-list2))
         flag-list1)))

;;; convert flag-list to string-list
(define (flag-list->string-list flag-lst)
  (map (λ(flag-sublist)
         (let ((environment-variable
                (string-append (symbol->string
                                (flag-type flag-sublist))
                               "=")))
           (string-join (cons environment-variable
                              (flag-string-list flag-sublist)))))
       flag-lst))


;;; build flags used in dpkg-buildflags

(define default-flag-list
  (flag-list
   '(CFLAGS "-g" "-O2")))

(define format-flag-list
  (flag-list
   '(CFLAGS "-Wformat" "-Werror=format-security")))

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

(define stackprotectorstrong-flag-list
  (flag-list
   '(CFLAGS "-fstack-protector-strong")))

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

(define bind-now-flag-list
  (flag-list
   '(LDFLAGS "-Wl,-z,now")))

(define pie-flag-list
  (flag-list
   '(CFLAGS "-fPIE")
   '(LDFLAGS "-fPIE" "-pie")))

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


;;; implement the bootstrap-build-system using syntax-case macro
;;; bootstrap-build-system use a bootstrap script
;;; to run autoreconf and generate documentation.
(define-syntax package*
  (lambda(x)
    ;; add autoconf, automake and perl as build dependencies
    ;; Modify the gnu-build-system
    ;; by adding bootstrap phase before configure phase.
    (define (extend-fields s-exp)
      (cond ((eq? (car s-exp) 'inputs)
	     (list 'inputs
		   (list 'quasiquote
			 (append '(("autoconf" ,autoconf)
				   ("automake" ,automake)
				   ("perl" ,perl))
				 (cadadr s-exp)))))
	    ((eq? (car s-exp) 'arguments)
	     (list
	      'arguments
	      (list
	       'quasiquote
	       (append
		'(#:phases
		  (modify-phases %standard-phases
				 (add-before 'configure
					     'bootstrap
					     (λ _
					       (zero?
						(system "./bootstrap"))))))
		(cadadr s-exp)))))
	    (else s-exp)))
    (syntax-case x ()
      ((_ . lst)
       (if (any (λ(sublist)
		  (equal? sublist
			  '(build-system
			    bootstrap-build-system)))
		(syntax->datum #'lst))
	   #`(package (build-system gnu-build-system)
		      #,@(datum->syntax
			  x
			  (map extend-fields
			       (remove (λ(sublist)
					 (equal? sublist
						 '(build-system
						   bootstrap-build-system)))
				       (syntax->datum #'lst)))))
	   #`(package #,@ #'lst))))))


(define-public mlucas
  ;; descriptions of the package
  (let ((short-description
         "Program to perform Lucas-Lehmer test on a Mersenne number")
        (long-description
         "mlucas is an open-source (and free/libre) program
for performing Lucas-Lehmer test on prime-exponent Mersenne numbers,
that is, integers of the form 2 ^ p - 1, with prime exponent p.
In short, everything you need to search for world-record Mersenne primes!
It has been used in the verification of various Mersenne primes,
including the 45th, 46th and 48th found Mersenne prime.

You may use it to test any suitable number as you wish,
but it is preferable that you do so in a coordinated fashion,
as part of the Great Internet Mersenne Prime Search (GIMPS).
For more information on GIMPS,
see <http://www.mersenne.org/prime.html> for details.
")
        ;; some dpkg-buildflags and custom build flags presented as flag-list
        (custom-flag-list
         (flag-list-
          (flag-list+ all-flag-list
                      (flag-list
                       '(CFLAGS "-Ofast"
                                "-pipe"
                                "-flto"
                                "-fno-aggressive-loop-optimizations")
                       '(LDFLAGS "-Wl,--as-needed")))
          default-flag-list)))
    ;; start package definition
    (package*
     (name "mlucas")
     (version "14.1")
     (source (origin
	      (method url-fetch)
	      (uri (string-append "http://hogranch.com/mayer/src/C/mlucas-"
				  version
				  ".tar.xz"))
	      (sha256
	       (base32
		"1i6j1479icxfwp3ixs6dk65qilv9hn7213q3iibndlgwjfmh0gb4"))))
     (build-system bootstrap-build-system)
     (arguments
      `(#:configure-flags
	'("--disable-NORMAL-CFLAGS"
	  "--disable-TRICKY-CFLAGS"
	  "--enable-MLUCAS-DEFAULT-PATH"
	  "--enable-verbose-compiler"
	  ,@(flag-list->string-list custom-flag-list))))
     (inputs `(("autogen" ,autogen)))
     (synopsis short-description)
     (description long-description)
     (home-page "http://hogranch.com/mayer/README.html")
     (license gpl2+))))