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
8.3 KiB

monads: Move '%store-monad' and related procedures where they belong. This turns (guix monads) into a generic module for monads, and moves the store monad and related monadic procedures in their corresponding module. * guix/monads.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file, package-file, package->derivation, package->cross-derivation, origin->derivation, imported-modules, compiled, modules, built-derivations, run-with-store): Move to... * guix/store.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file): ... here. (%guile-for-build): New variable. (run-with-store): Moved from monads.scm. Remove default value for #:guile-for-build. * guix/packages.scm (default-guile): Export. (set-guile-for-build): New procedure. (package-file, package->derivation, package->cross-derivation, origin->derivation): Moved from monads.scm. * guix/derivations.scm (%guile-for-build): Remove. (imported-modules): Rename to... (%imported-modules): ... this. (compiled-modules): Rename to... (%compiled-modules): ... this. (built-derivations, imported-modules, compiled-modules): New procedures. * gnu/services/avahi.scm, gnu/services/base.scm, gnu/services/dbus.scm, gnu/services/dmd.scm, gnu/services/networking.scm, gnu/services/ssh.scm, gnu/services/xorg.scm, gnu/system/install.scm, gnu/system/linux-initrd.scm, gnu/system/shadow.scm, guix/download.scm, guix/gexp.scm, guix/git-download.scm, guix/profiles.scm, guix/svn-download.scm, tests/monads.scm: Adjust imports accordingly. * guix/monad-repl.scm (default-guile-derivation): New procedure. (store-monad-language, run-in-store): Use it. * build-aux/hydra/gnu-system.scm (qemu-jobs): Add explicit 'set-guile-for-build' call. * guix/scripts/archive.scm (derivation-from-expression): Likewise. * guix/scripts/build.scm (options/resolve-packages): Likewise. * guix/scripts/environment.scm (guix-environment): Likewise. * guix/scripts/system.scm (guix-system): Likewise. * doc/guix.texi (The Store Monad): Adjust module names accordingly.
7 years ago
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015 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. #:use-module (gnu packages)
  25. #:use-module (gnu packages bootstrap)
  26. #:use-module ((gnu packages base) #:select (coreutils))
  27. #:use-module (ice-9 match)
  28. #:use-module (rnrs io ports)
  29. #:use-module (srfi srfi-1)
  30. #:use-module (srfi srfi-26)
  31. #:use-module (srfi srfi-64))
  32. ;; Test the (guix monads) module.
  33. (define %store
  34. (open-connection-for-tests))
  35. (define %monads
  36. (list %identity-monad %store-monad %state-monad))
  37. (define %monad-run
  38. (list identity
  39. (cut run-with-store %store <>)
  40. (cut run-with-state <> '())))
  41. (define-syntax-rule (values->list exp)
  42. (call-with-values (lambda () exp)
  43. list))
  44. (test-begin "monads")
  45. (test-assert "monad?"
  46. (and (every monad? %monads)
  47. (every (compose procedure? monad-bind) %monads)
  48. (every (compose procedure? monad-return) %monads)))
  49. ;; The 3 "monad laws": <http://www.haskell.org/haskellwiki/Monad_laws>.
  50. (test-assert "left identity"
  51. (every (lambda (monad run)
  52. (let ((number (random 777)))
  53. (with-monad monad
  54. (define (f x)
  55. (return (* (1+ number) 2)))
  56. (= (run (>>= (return number) f))
  57. (run (f number))))))
  58. %monads
  59. %monad-run))
  60. (test-assert "right identity"
  61. (every (lambda (monad run)
  62. (with-monad monad
  63. (let ((number (return (random 777))))
  64. (= (run (>>= number return))
  65. (run number)))))
  66. %monads
  67. %monad-run))
  68. (test-assert "associativity"
  69. (every (lambda (monad run)
  70. (with-monad monad
  71. (define (f x)
  72. (return (+ 1 x)))
  73. (define (g x)
  74. (return (* 2 x)))
  75. (let ((number (return (random 777))))
  76. (= (run (>>= (>>= number f) g))
  77. (run (>>= number (lambda (x) (>>= (f x) g))))))))
  78. %monads
  79. %monad-run))
  80. (test-assert "lift"
  81. (every (lambda (monad run)
  82. (let ((f (lift1 1+ monad)))
  83. (with-monad monad
  84. (let ((number (random 777)))
  85. (= (run (>>= (return number) f))
  86. (1+ number))))))
  87. %monads
  88. %monad-run))
  89. (test-assert "mbegin"
  90. (every (lambda (monad run)
  91. (with-monad monad
  92. (let* ((been-there? #f)
  93. (number (mbegin monad
  94. (return 1)
  95. (begin
  96. (set! been-there? #t)
  97. (return 2))
  98. (return 3))))
  99. (and (= (run number) 3)
  100. been-there?))))
  101. %monads
  102. %monad-run))
  103. (test-assert "mlet* + text-file + package-file"
  104. (run-with-store %store
  105. (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))
  106. (file (text-file "monadic" guile)))
  107. (return (equal? (call-with-input-file file get-string-all)
  108. guile)))
  109. #:guile-for-build (package-derivation %store %bootstrap-guile)))
  110. (test-assert "package-file, default system"
  111. ;; The default system should be the one at '>>=' time, not the one at
  112. ;; invocation time. See <http://bugs.gnu.org/18002>.
  113. (run-with-store %store
  114. (mlet* %store-monad
  115. ((system -> (%current-system))
  116. (file (parameterize ((%current-system "foobar64-linux"))
  117. (package-file coreutils "bin/ls")))
  118. (cu (package->derivation coreutils)))
  119. (return (string=? file
  120. (string-append (derivation->output-path cu)
  121. "/bin/ls"))))
  122. #:guile-for-build (package-derivation %store %bootstrap-guile)))
  123. (test-assert "package-file + package->cross-derivation"
  124. (run-with-store %store
  125. (mlet* %store-monad ((target -> "mips64el-linux-gnu")
  126. (file (package-file coreutils "bin/ls"
  127. #:target target))
  128. (xcu (package->cross-derivation coreutils target)))
  129. (let ((output (derivation->output-path xcu)))
  130. (return (string=? file (string-append output "/bin/ls")))))
  131. #:guile-for-build (package-derivation %store %bootstrap-guile)))
  132. (test-assert "interned-file"
  133. (run-with-store %store
  134. (mlet* %store-monad ((file -> (search-path %load-path "guix.scm"))
  135. (a (interned-file file))
  136. (b (interned-file file "b")))
  137. (return (equal? (call-with-input-file file get-string-all)
  138. (call-with-input-file a get-string-all)
  139. (call-with-input-file b get-string-all))))
  140. #:guile-for-build (package-derivation %store %bootstrap-guile)))
  141. (test-assert "mapm"
  142. (every (lambda (monad run)
  143. (with-monad monad
  144. (equal? (run (mapm monad (lift1 1+ monad) (map return (iota 10))))
  145. (map 1+ (iota 10)))))
  146. %monads
  147. %monad-run))
  148. (test-assert "sequence"
  149. (every (lambda (monad run)
  150. (let* ((input (iota 100))
  151. (order '()))
  152. (define (frob i)
  153. (mlet monad ((foo (return 'foo)))
  154. ;; The side effect here is used to keep track of the order in
  155. ;; which monadic values are bound. Perform the side effect
  156. ;; within a '>>=' so that it is performed when the return
  157. ;; value is actually bound.
  158. (set! order (cons i order))
  159. (return i)))
  160. (and (equal? input
  161. (run (sequence monad (map frob input))))
  162. ;; Make sure this is from left to right.
  163. (equal? order (reverse input)))))
  164. %monads
  165. %monad-run))
  166. (test-assert "listm"
  167. (every (lambda (monad run)
  168. (run (with-monad monad
  169. (let ((lst (listm monad
  170. (return 1) (return 2) (return 3))))
  171. (mlet monad ((lst lst))
  172. (return (equal? '(1 2 3) lst)))))))
  173. %monads
  174. %monad-run))
  175. (test-assert "anym"
  176. (every (lambda (monad run)
  177. (eq? (run (with-monad monad
  178. (let ((lst (list (return 1) (return 2) (return 3))))
  179. (anym monad
  180. (lambda (x)
  181. (and (odd? x) 'odd!))
  182. lst))))
  183. 'odd!))
  184. %monads
  185. %monad-run))
  186. (test-equal "set-current-state"
  187. (list '(a a d) 'd)
  188. (values->list
  189. (run-with-state
  190. (mlet* %state-monad ((init (current-state))
  191. (init2 (set-current-state 'b)))
  192. (mbegin %state-monad
  193. (set-current-state 'c)
  194. (set-current-state 'd)
  195. (mlet %state-monad ((last (current-state)))
  196. (return (list init init2 last)))))
  197. 'a)))
  198. (test-equal "state-push etc."
  199. (list '((z . 2) (p . (1)) (a . (1))) '(2 1))
  200. (values->list
  201. (run-with-state
  202. (mbegin %state-monad
  203. (state-push 1) ;(1)
  204. (state-push 2) ;(2 1)
  205. (mlet* %state-monad ((z (state-pop)) ;(1)
  206. (p (current-state))
  207. (a (state-push z))) ;(2 1)
  208. (return `((z . ,z) (p . ,p) (a . ,a)))))
  209. '())))
  210. (test-end "monads")
  211. (exit (= (test-runner-fail-count (test-runner-current)) 0))