Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

243 lines
9.1 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (test-monads)
  19. #:use-module (guix tests)
  20. #:use-module (guix store)
  21. #:use-module (guix monads)
  22. #:use-module (guix derivations)
  23. #:use-module ((guix packages)
  24. #:select (package-derivation %current-system))
  25. #:use-module (gnu packages)
  26. #:use-module (gnu packages bootstrap)
  27. #:use-module ((gnu packages base) #:select (coreutils))
  28. #:use-module (ice-9 match)
  29. #:use-module (rnrs io ports)
  30. #:use-module (srfi srfi-1)
  31. #:use-module (srfi srfi-26)
  32. #:use-module (srfi srfi-64))
  33. ;; Test the (guix store) module.
  34. (define %store
  35. (open-connection-for-tests))
  36. (define %monads
  37. (list %identity-monad %store-monad))
  38. (define %monad-run
  39. (list identity
  40. (cut run-with-store %store <>)))
  41. (test-begin "monads")
  42. (test-assert "monad?"
  43. (and (every monad? %monads)
  44. (every (compose procedure? monad-bind) %monads)
  45. (every (compose procedure? monad-return) %monads)))
  46. ;; The 3 "monad laws": <http://www.haskell.org/haskellwiki/Monad_laws>.
  47. (test-assert "left identity"
  48. (every (lambda (monad run)
  49. (let ((number (random 777)))
  50. (with-monad monad
  51. (define (f x)
  52. (return (* (1+ number) 2)))
  53. (= (run (>>= (return number) f))
  54. (run (f number))))))
  55. %monads
  56. %monad-run))
  57. (test-assert "right identity"
  58. (every (lambda (monad run)
  59. (with-monad monad
  60. (let ((number (return (random 777))))
  61. (= (run (>>= number return))
  62. (run number)))))
  63. %monads
  64. %monad-run))
  65. (test-assert "associativity"
  66. (every (lambda (monad run)
  67. (with-monad monad
  68. (define (f x)
  69. (return (+ 1 x)))
  70. (define (g x)
  71. (return (* 2 x)))
  72. (let ((number (return (random 777))))
  73. (= (run (>>= (>>= number f) g))
  74. (run (>>= number (lambda (x) (>>= (f x) g))))))))
  75. %monads
  76. %monad-run))
  77. (test-assert "lift"
  78. (every (lambda (monad run)
  79. (let ((f (lift1 1+ monad)))
  80. (with-monad monad
  81. (let ((number (random 777)))
  82. (= (run (>>= (return number) f))
  83. (1+ number))))))
  84. %monads
  85. %monad-run))
  86. (test-assert "mlet* + text-file + package-file"
  87. (run-with-store %store
  88. (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))
  89. (file (text-file "monadic" guile)))
  90. (return (equal? (call-with-input-file file get-string-all)
  91. guile)))
  92. #:guile-for-build (package-derivation %store %bootstrap-guile)))
  93. (test-assert "package-file, default system"
  94. ;; The default system should be the one at '>>=' time, not the one at
  95. ;; invocation time. See <http://bugs.gnu.org/18002>.
  96. (run-with-store %store
  97. (mlet* %store-monad
  98. ((system -> (%current-system))
  99. (file (parameterize ((%current-system "foobar64-linux"))
  100. (package-file coreutils "bin/ls")))
  101. (cu (package->derivation coreutils)))
  102. (return (string=? file
  103. (string-append (derivation->output-path cu)
  104. "/bin/ls"))))
  105. #:guile-for-build (package-derivation %store %bootstrap-guile)))
  106. (test-assert "package-file + package->cross-derivation"
  107. (run-with-store %store
  108. (mlet* %store-monad ((target -> "mips64el-linux-gnu")
  109. (file (package-file coreutils "bin/ls"
  110. #:target target))
  111. (xcu (package->cross-derivation coreutils target)))
  112. (let ((output (derivation->output-path xcu)))
  113. (return (string=? file (string-append output "/bin/ls")))))
  114. #:guile-for-build (package-derivation %store %bootstrap-guile)))
  115. (test-assert "interned-file"
  116. (run-with-store %store
  117. (mlet* %store-monad ((file -> (search-path %load-path "guix.scm"))
  118. (a (interned-file file))
  119. (b (interned-file file "b")))
  120. (return (equal? (call-with-input-file file get-string-all)
  121. (call-with-input-file a get-string-all)
  122. (call-with-input-file b get-string-all))))
  123. #:guile-for-build (package-derivation %store %bootstrap-guile)))
  124. (define derivation-expression
  125. (@@ (guix monads) derivation-expression))
  126. (test-assert "mlet* + derivation-expression"
  127. (run-with-store %store
  128. (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))
  129. (gdrv (package->derivation %bootstrap-guile))
  130. (exp -> `(let ((out (assoc-ref %outputs "out")))
  131. (mkdir out)
  132. (symlink ,guile
  133. (string-append out "/guile-rocks"))))
  134. (drv (derivation-expression "rocks" exp
  135. #:inputs
  136. `(("g" ,gdrv))))
  137. (out -> (derivation->output-path drv))
  138. (built? (built-derivations (list drv))))
  139. (return (and built?
  140. (equal? guile
  141. (readlink (string-append out "/guile-rocks"))))))
  142. #:guile-for-build (package-derivation %store %bootstrap-guile)))
  143. (test-assert "text-file*"
  144. (let ((references (store-lift references)))
  145. (run-with-store %store
  146. (mlet* %store-monad
  147. ((drv (package->derivation %bootstrap-guile))
  148. (guile -> (derivation->output-path drv))
  149. (file (text-file "bar" "This is bar."))
  150. (text (text-file* "foo"
  151. %bootstrap-guile "/bin/guile "
  152. `(,%bootstrap-guile "out") "/bin/guile "
  153. drv "/bin/guile "
  154. file))
  155. (done (built-derivations (list text)))
  156. (out -> (derivation->output-path text))
  157. (refs (references out)))
  158. ;; Make sure we get the right references and the right content.
  159. (return (and (lset= string=? refs (list guile file))
  160. (equal? (call-with-input-file out get-string-all)
  161. (string-append guile "/bin/guile "
  162. guile "/bin/guile "
  163. guile "/bin/guile "
  164. file)))))
  165. #:guile-for-build (package-derivation %store %bootstrap-guile))))
  166. (test-assert "mapm"
  167. (every (lambda (monad run)
  168. (with-monad monad
  169. (equal? (run (mapm monad (lift1 1+ monad) (map return (iota 10))))
  170. (map 1+ (iota 10)))))
  171. %monads
  172. %monad-run))
  173. (test-assert "sequence"
  174. (every (lambda (monad run)
  175. (let* ((input (iota 100))
  176. (order '()))
  177. (define (frob i)
  178. (mlet monad ((foo (return 'foo)))
  179. ;; The side effect here is used to keep track of the order in
  180. ;; which monadic values are bound. Perform the side effect
  181. ;; within a '>>=' so that it is performed when the return
  182. ;; value is actually bound.
  183. (set! order (cons i order))
  184. (return i)))
  185. (and (equal? input
  186. (run (sequence monad (map frob input))))
  187. ;; Make sure this is from left to right.
  188. (equal? order (reverse input)))))
  189. %monads
  190. %monad-run))
  191. (test-assert "listm"
  192. (every (lambda (monad run)
  193. (run (with-monad monad
  194. (let ((lst (listm monad
  195. (return 1) (return 2) (return 3))))
  196. (mlet monad ((lst lst))
  197. (return (equal? '(1 2 3) lst)))))))
  198. %monads
  199. %monad-run))
  200. (test-assert "anym"
  201. (every (lambda (monad run)
  202. (eq? (run (with-monad monad
  203. (let ((lst (list (return 1) (return 2) (return 3))))
  204. (anym monad
  205. (lambda (x)
  206. (and (odd? x) 'odd!))
  207. lst))))
  208. 'odd!))
  209. %monads
  210. %monad-run))
  211. (test-end "monads")
  212. (exit (= (test-runner-fail-count (test-runner-current)) 0))