;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;;
;;; 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 (test-hackage)
  #:use-module (guix </td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=daf0729533c791d06cd0d3f001fb5df03eacb433'>refs</a><a href='/guix/log/gnu/packages/libffi.scm'>log</a><a href='/guix/tree/gnu/packages/libffi.scm?id=daf0729533c791d06cd0d3f001fb5df03eacb433'>tree</a><a href='/guix/commit/gnu/packages/libffi.scm?id=daf0729533c791d06cd0d3f001fb5df03eacb433'>commit</a><a class='active' href='/guix/diff/gnu/packages/libffi.scm?id=daf0729533c791d06cd0d3f001fb5df03eacb433'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/gnu/packages/libffi.scm'>
<input type='hidden' name='id' value='daf0729533c791d06cd0d3f001fb5df03eacb433'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/diff/?id=daf0729533c791d06cd0d3f001fb5df03eacb433'>root</a>/<a href='/guix/diff/gnu?id=daf0729533c791d06cd0d3f001fb5df03eacb433'>gnu</a>/<a href='/guix/diff/gnu/packages?id=daf0729533c791d06cd0d3f001fb5df03eacb433'>packages</a>/<a href='/guix/diff/gnu/packages/libffi.scm?id=daf0729533c791d06cd0d3f001fb5df03eacb433'>libffi.scm</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='daf0729533c791d06cd0d3f001fb5df03eacb433'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><div class='diffstat-header'><a href='/guix/diff/?id=daf0729533c791d06cd0d3f001fb5df03eacb433'>Diffstat</a> (limited to 'gnu/packages/libffi.scm')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
me: test-me
library foobar
    build-depends: foo, bar
library
    build-depends: bar, baz
")

(test-begin "hackage")

(define-syntax-rule (define-package-matcher name pattern)
  (define* (name obj)
    (match obj
      (pattern #t)
      (x       (pk 'fail x #f)))))

(define-package-matcher match-ghc-foo
  ('package
    ('name "ghc-foo")
    ('version "1.0.0")
    ('source
     ('origin
       ('method 'url-fetch)
       ('uri ('hackage-uri "foo" 'version))
       ('sha256
        ('base32
         (? string? hash)))))
    ('build-system 'haskell-build-system)
    ('inputs ('list 'ghc-http))
    ('home-page "http://test.org")
    ('synopsis (? string?))
    ('description (? string?))
    ('license 'license:bsd-3)))

(define* (eval-test-with-cabal test-cabal matcher #:key (cabal-environment '()))
  (define port (open-input-string test-cabal))
  (matcher (hackage->guix-package "foo" #:port port #:cabal-environment cabal-environment)))

(test-assert "hackage->guix-package test 1"
  (eval-test-with-cabal test-cabal-1 match-ghc-foo))

(test-assert "hackage->guix-package test 2"
  (eval-test-with-cabal test-cabal-2 match-ghc-foo))

(test-assert "hackage->guix-package test 3"
  (eval-test-with-cabal test-cabal-3 match-ghc-foo
                        #:cabal-environment '(("impl" . "ghc-7.8"))))

(test-assert "hackage->guix-package test 4"
  (eval-test-with-cabal test-cabal-4 match-ghc-foo
                        #:cabal-environment '(("impl" . "ghc-7.8"))))

(test-assert "hackage->guix-package test 5"
  (eval-test-with-cabal test-cabal-5 match-ghc-foo
                        #:cabal-environment '(("impl" . "ghc-7.8"))))

(define-package-matcher match-ghc-foo-6
  ('package
    ('name "ghc-foo")
    ('version "1.0.0")
    ('source
     ('origin
       ('method 'url-fetch)
       ('uri ('hackage-uri "foo" 'version))
       ('sha256
        ('base32
         (? string? hash)))))
    ('build-system 'haskell-build-system)
    ('inputs ('list 'ghc-b 'ghc-http))
    ('native-inputs ('list 'ghc-haskell-gi))
    ('home-page "http://test.org")
    ('synopsis (? string?))
    ('description (? string?))
    ('license 'license:bsd-3)))

(test-assert "hackage->guix-package test 6"
  (eval-test-with-cabal test-cabal-6 match-ghc-foo-6))

;; Check multi-line layouted description.
(define test-cabal-multiline-layout
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description:   first line
               second line
license: BSD3
executable cabal
  build-depends:
    HTTP       >= 4000.2.5 && < 4000.3,
    mtl        >= 2.0      && < 3
")

(test-assert "hackage->guix-package test multiline desc (layout)"
  (eval-test-with-cabal test-cabal-multiline-layout match-ghc-foo))

;; Check multi-line braced description.
(define test-cabal-multiline-braced
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: {
first line
second line
}
license: BSD3
executable cabal
  build-depends:
    HTTP       >= 4000.2.5 && < 4000.3,
    mtl        >= 2.0      && < 3
")

(test-assert "hackage->guix-package test multiline desc (braced)"
  (eval-test-with-cabal test-cabal-multiline-braced match-ghc-foo))

;; Check mixed layout. Compare e.g. warp.
(define test-cabal-mixed-layout
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
executable cabal
    build-depends:
      HTTP       >= 4000.2.5 && < 4000.3,
      mtl        >= 2.0      && < 3
  ghc-options: -Wall
")

;; Fails: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=35743
(test-expect-fail 1)
(test-assert "hackage->guix-package test mixed layout"
  (eval-test-with-cabal test-cabal-mixed-layout match-ghc-foo))

;; Check flag executable. Compare e.g. darcs.
(define test-cabal-flag-executable
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
flag executable
  description: Build executable
  default:     True
executable cabal
  if !flag(executable)
    buildable: False
  else
    buildable: True

  build-depends:
    HTTP       >= 4000.2.5 && < 4000.3,
    mtl        >= 2.0      && < 3
")

(test-assert "hackage->guix-package test flag executable"
  (eval-test-with-cabal test-cabal-flag-executable match-ghc-foo))

;; There is no mandatory space between property name and value.
(define test-cabal-property-no-space
  "name:foo
version:1.0.0
homepage:http://test.org
synopsis:synopsis
description:description
license:BSD3
common bench-defaults
  ghc-options:-Wall
executable cabal
  build-depends:
    HTTP       >= 4000.2.5 && < 4000.3,
    mtl        >= 2.0      && < 3
")

(test-assert "hackage->guix-package test properties without space"
  (eval-test-with-cabal test-cabal-property-no-space match-ghc-foo))

;; There may be no final newline terminating a property.
(define test-cabal-no-final-newline
"name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
executable cabal
  build-depends: HTTP       >= 4000.2.5 && < 4000.3, mtl        >= 2.0      && < 3")

(test-expect-fail 1)
(test-assert "hackage->guix-package test without final newline"
  (eval-test-with-cabal test-cabal-no-final-newline match-ghc-foo))

;; Make sure internal libraries will not be part of the dependencies,
;; ignore case.
(define test-cabal-internal-library-ignored
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
executable cabal
  build-depends:
    HTTP       >= 4000.2.5 && < 4000.3,
    internAl
library internaL
  build-depends: mtl        >= 2.0      && < 3
")

(test-assert "hackage->guix-package test internal libraries are ignored"
  (eval-test-with-cabal test-cabal-internal-library-ignored match-ghc-foo))

;; Check if-elif-else statements
(define test-cabal-if
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
library
  if os(first)
    Build-depends: ghc-c
")

(define test-cabal-else
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
library
  if os(first)
    Build-depends: ghc-a
  else
    Build-depends: ghc-c
")

(define test-cabal-elif
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
library
  if os(first)
    Build-depends: ghc-a
  elif os(second)
    Build-depends: ghc-b
  elif os(guix)
    Build-depends: ghc-c
  elif os(third)
    Build-depends: ghc-d
  else
    Build-depends: ghc-e
")

;; Try the same with different bracket styles
(define test-cabal-elif-brackets
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
library
  if os(first) {
    Build-depends: ghc-a
  }
  elif os(second)
    Build-depends: ghc-b
  elif os(guix) { Build-depends: ghc-c }
  elif os(third) {
    Build-depends: ghc-d }
  elif os(fourth)
  {
    Build-depends: ghc-d
  } else
    Build-depends: ghc-e
")

(define-package-matcher match-ghc-elif
  ('package
    ('name "ghc-foo")
    ('version "1.0.0")
    ('source
     ('origin
       ('method 'url-fetch)
       ('uri ('hackage-uri "foo" 'version))
       ('sha256
        ('base32
         (? string? hash)))))
    ('build-system 'haskell-build-system)
    ('inputs ('list 'ghc-c))
    ('home-page "http://test.org")
    ('synopsis (? string?))
    ('description (? string?))
    ('license 'license:bsd-3)))

(test-assert "hackage->guix-package test lonely if statement"
  (eval-test-with-cabal test-cabal-else match-ghc-elif
                        #:cabal-environment '(("os" . "guix"))))

(test-assert "hackage->guix-package test else statement"
  (eval-test-with-cabal test-cabal-else match-ghc-elif
                        #:cabal-environment '(("os" . "guix"))))

(test-assert "hackage->guix-package test elif statement"
  (eval-test-with-cabal test-cabal-elif match-ghc-elif
                        #:cabal-environment '(("os" . "guix"))))

(test-assert "hackage->guix-package test elif statement with brackets"
  (eval-test-with-cabal test-cabal-elif-brackets match-ghc-elif
                        #:cabal-environment '(("os" . "guix"))))

;; Check Hackage Cabal revisions.
(define test-cabal-revision
  "name: foo
version: 1.0.0
x-revision: 2
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
executable cabal
  build-depends:
    HTTP       >= 4000.2.5 && < 4000.3,
    mtl        >= 2.0      && < 3
")

(define-package-matcher match-ghc-foo-revision
  ('package
    ('name "ghc-foo")
    ('version "1.0.0")
    ('source
     ('origin
       ('method 'url-fetch)
       ('uri ('hackage-uri "foo" 'version))
       ('sha256
        ('base32
         (? string? hash)))))
    ('build-system 'haskell-build-system)
    ('inputs ('list 'ghc-http))
    ('arguments
     ('quasiquote
      ('#:cabal-revision
       ("2" "0xxd88fb659f0krljidbvvmkh9ppjnx83j0nqzx8whcg4n5qbyng"))))
    ('home-page "http://test.org")
    ('synopsis (? string?))
    ('description (? string?))
    ('license 'license:bsd-3)))

(test-assert "hackage->guix-package test cabal revision"
  (eval-test-with-cabal test-cabal-revision match-ghc-foo-revision))

(test-assert "read-cabal test 1"
  (match (call-with-input-string test-read-cabal-1 read-cabal)
    ((("name" ("test-me"))
      ('section 'library #f
                (('if ('flag "base4point8")
                      (("build-depends" ("base >= 4.8 && < 5")))
                      (('if ('flag "base4")
                            (("build-depends" ("base >= 4 && < 4.8")))
                            (('if ('flag "base3")
                                  (("build-depends" ("base >= 3 && < 4")))
                                  (("build-depends" ("base < 3"))))))))
                 ('if ('or ('flag "base4point8")
                           ('and ('flag "base4") ('flag "base3")))
                      (("build-depends" ("random")))
                      ())
                 ("build-depends" ("containers"))
                 ("exposed-modules" ("Test.QuickCheck.Exception")))))
     #t)
    (x (pk 'fail x #f))))

(test-assert "read-cabal test: if brackets on the same line"
  (match (call-with-input-string test-read-cabal-2 read-cabal)
    ((("name" ("test-me"))
        ('section 'common "defaults"
          (('if ('os "foobar")
               (("cc-options" ("-DBARBAZ ")))
               ()))))
     #t)
    (x (pk 'fail x #f))))

(test-expect-fail 1)
(test-assert "read-cabal test: property brackets on new line"
  (match (call-with-input-string test-read-cabal-brackets-newline read-cabal)
    ((("name" ("test-me"))
        ('section 'common "defaults"
          (("build-depends" ("foobar ,  barbaz")))))
     #t)
    (x (pk 'fail x #f))))

(test-assert "read-cabal test: library name"
  (match (call-with-input-string test-read-cabal-library-name read-cabal)
    ((("name" ("test-me"))
        ('section 'library "foobar"
          (("build-depends" ("foo, bar"))))
        ('section 'library #f
          (("build-depends" ("bar, baz")))))
     #t)
    (x (pk 'fail x #f))))

(define test-cabal-import
  "name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
common commons
  build-depends:
    HTTP       >= 4000.2.5 && < 4000.3,
    mtl        >= 2.0      && < 3

executable cabal
  import: commons
")

(define-package-matcher match-ghc-foo-import
  ('package
    ('name "ghc-foo")
    ('version "1.0.0")
    ('source
     ('origin
       ('method 'url-fetch)
       ('uri ('hackage-uri "foo" 'version))
       ('sha256
        ('base32
         (? string? hash)))))
    ('build-system 'haskell-build-system)
    ('inputs ('list 'ghc-http))
    ('home-page "http://test.org")
    ('synopsis (? string?))
    ('description (? string?))
    ('license 'license:bsd-3)))

(test-assert "hackage->guix-package test cabal import"
  (eval-test-with-cabal test-cabal-import match-ghc-foo-import))

(test-end "hackage")